- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/amg/castz] Fumble around trying to fix optimisation bugs
by Adam Gundry (＠adamgundry) 25 Nov '25

25 Nov '25

Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC Commits: 307ee28a by Adam Gundry at 2025-11-25T14:26:41+00:00 Fumble around trying to fix optimisation bugs - - - - - 3 changed files: - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/SimpleOpt.hs Changes: ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -2246,13 +2246,13 @@ etaInfoApp in_scope expr eis -- Beta-reduction if possible, pushing any intervening casts past -- the argument. See Note [The EtaInfo mechanism] go subst (Lam v e) (EI (b:bs) mco) - | Just (arg,mco') <- pushCoArg (exprType (Lam v e)) mco (varToCoreExpr b) + | Just (arg,_, mco') <- pushCoArg (exprType (Lam v e)) mco (varToCoreExpr b) = go (Core.extendSubst subst v arg) e (EI bs mco') -- Stop pushing down; just wrap the expression up -- See Note [Check for reflexive casts in eta expansion] go subst e (EI bs mco) = Core.substExprSC subst e - `mkCastCo` checkReflexiveCastCo (exprType e) mco -- TODO check type + `mkCastCo` checkReflexiveCastCo (exprType e) mco `mkVarApps` bs -------------- @@ -2359,12 +2359,12 @@ mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty -- with an explicit lambda having a non-function type mkEtaForAllMCo :: ForAllTyBinder -> Type -> CastCoercion -> CastCoercion -mkEtaForAllMCo (Bndr tcv vis) ty mco +mkEtaForAllMCo bdnr@(Bndr tcv vis) ty mco = case mco of ReflCastCo | vis == coreTyLamForAllTyFlag -> ReflCastCo | otherwise -> mk_fco (mkRepReflCo ty) CCoercion co -> mk_fco co - ZCoercion _ty2 cos -> ZCoercion ty cos -- TODO: is ty right? + ZCoercion tyR cos -> ZCoercion (mkForAllTy bdnr tyR) cos where mk_fco co = CCoercion (mkForAllCo tcv vis coreTyLamForAllTyFlag MRefl co) -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly @@ -2871,17 +2871,17 @@ Here we implement the "push rules" from FC papers: by pushing the coercion into the arguments -} -pushCoArgs :: Type -> CastCoercion -> [CoreArg] -> Maybe ([CoreArg], CastCoercion) -pushCoArgs _ co [] = return ([], co) +pushCoArgs :: Type -> CastCoercion -> [CoreArg] -> Maybe ([CoreArg], Type, CastCoercion) +pushCoArgs fun_ty co [] = return ([], fun_ty, co) pushCoArgs fun_ty co (arg:args) = do - { (arg', m_co1) <- pushCoArg fun_ty co arg + { (arg', ty, m_co1) <- pushCoArg fun_ty co arg ; if isReflCastCo m_co1 - then return (arg':args, ReflCastCo) - else do { (args', m_co2) <- pushCoArgs (funResultTy fun_ty) m_co1 args -- TODO check type - ; return (arg':args', m_co2) } + then return (arg':args, ty, ReflCastCo) + else do { (args', ty', m_co2) <- pushCoArgs ty m_co1 args + ; return (arg':args', ty', m_co2) } } -pushCoArg :: Type -> CastCoercion -> CoreArg -> Maybe (CoreArg, CastCoercion) +pushCoArg :: Type -> CastCoercion -> CoreArg -> Maybe (CoreArg, Type, CastCoercion) -- We have (fun |> co) arg, and we want to transform it to -- (fun arg) |> co -- This may fail, e.g. if (fun :: N) where N is a newtype @@ -2889,22 +2889,22 @@ pushCoArg :: Type -> CastCoercion -> CoreArg -> Maybe (CoreArg, CastCoercion) -- 'co' is always Representational pushCoArg fun_ty co arg | Type ty <- arg - = do { (ty', m_co') <- pushCastCoTyArg co ty - ; return (Type ty', m_co') } + = do { (ty', ty, m_co') <- pushCastCoTyArg co ty + ; return (Type ty', ty, m_co') } | otherwise - = do { (arg_mco, m_co') <- pushCastCoValArg fun_ty co - ; let arg_mco' = checkReflexiveCastCo (funArgTy fun_ty) arg_mco + = do { (arg_ty, arg_mco, res_ty, m_co') <- pushCastCoValArg fun_ty co + ; let arg_mco' = checkReflexiveCastCo arg_ty arg_mco -- checkReflexiveCastCo: see Note [Check for reflexive casts in eta expansion] -- The coercion is very often (arg_co -> res_co), but without -- the argument coercion actually being ReflCo - ; return (arg `mkCastCo` arg_mco', m_co') } + ; return (arg `mkCastCo` arg_mco', res_ty, m_co') } -pushCastCoTyArg :: CastCoercion -> Type -> Maybe (Type, CastCoercion) +pushCastCoTyArg :: CastCoercion -> Type -> Maybe (Type, Type, CastCoercion) pushCastCoTyArg (CCoercion co) ty = pushCoTyArg co ty -pushCastCoTyArg ReflCastCo ty = Just (ty, ReflCastCo) +pushCastCoTyArg ReflCastCo ty = Just (ty, error "TODO: asdasdad", ReflCastCo) pushCastCoTyArg (ZCoercion _fun_ty _cos) _ty = Nothing -- TODO do better -pushCoTyArg :: CoercionR -> Type -> Maybe (Type, CastCoercion) +pushCoTyArg :: CoercionR -> Type -> Maybe (Type, Type, CastCoercion) -- We have (fun |> co) @ty -- Push the coercion through to return -- (fun @ty') |> co' @@ -2916,11 +2916,11 @@ pushCoTyArg co ty -- -- = Just (ty, Nothing) | isReflCo co - = Just (ty, ReflCastCo) + = Just (ty, coercionLKind co2, ReflCastCo) | isForAllTy_ty tyL = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $ - Just (ty `mkCastTy` co1, CCoercion co2) + Just (ty `mkCastTy` co1, coercionLKind co2, CCoercion co2) | otherwise = Nothing @@ -2940,14 +2940,14 @@ pushCoTyArg co ty -- co2 :: ty1[ (ty|>co1)/a1 ] ~R ty2[ ty/a2 ] -- Arg of mkInstCo is always nominal, hence Nominal -pushCastCoValArg :: Type -> CastCoercion -> Maybe (CastCoercion, CastCoercion) -pushCastCoValArg _ ReflCastCo = Just (ReflCastCo, ReflCastCo) +pushCastCoValArg :: Type -> CastCoercion -> Maybe (Type, CastCoercion, Type, CastCoercion) +pushCastCoValArg tyL ReflCastCo = Just (funArgTy tyL, ReflCastCo, funResultTy tyL, ReflCastCo) pushCastCoValArg _ (CCoercion co) = pushCoValArg co pushCastCoValArg tyL (ZCoercion tyR cos) | isFunTy tyL -- TODO: do we need to check this or can we assume it? , isFunTy tyR , typeHasFixedRuntimeRep new_arg_ty - = Just (ZCoercion new_arg_ty cos, ZCoercion (funResultTy tyR) cos) + = Just (funArgTy tyL, ZCoercion new_arg_ty cos, funResultTy tyL, ZCoercion (funResultTy tyR) cos) | otherwise = Nothing where new_arg_ty = funArgTy tyR @@ -2963,7 +2963,7 @@ pushCastCoValArg tyL (ZCoercion tyR cos) -- If the LHS is well-typed, then so is the RHS. In particular, the argument -- @arg |> co_arg@ is guaranteed to have a fixed 'RuntimeRep', in the sense of -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -pushCoValArg :: CoercionR -> Maybe (CastCoercion, CastCoercion) +pushCoValArg :: CoercionR -> Maybe (Type, CastCoercion, Type, CastCoercion) pushCoValArg co -- The following is inefficient - don't do `eqType` here, the coercion -- optimizer will take care of it. See #14737. @@ -2971,7 +2971,7 @@ pushCoValArg co -- -- = Just (mkRepReflCo arg, Nothing) | isReflCo co - = Just (ReflCastCo, ReflCastCo) + = Just (old_arg_ty, ReflCastCo, funResultTy tyL, ReflCastCo) | isFunTy tyL , (_, co1, co2) <- decomposeFunCo co @@ -2990,7 +2990,7 @@ pushCoValArg co (vcat [ text "co:" <+> ppr co , text "old_arg_ty:" <+> ppr old_arg_ty , text "new_arg_ty:" <+> ppr new_arg_ty ]) $ - Just (coToCastCo (mkSymCo co1), coToCastCo co2) + Just (old_arg_ty, coToCastCo (mkSymCo co1), funResultTy tyL, coToCastCo co2) -- Critically, coToCastCo to checks for ReflCo; the whole coercion may not -- be reflexive, but either of its components might be -- We could use isReflexiveCo, but it's not clear if the benefit ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1715,10 +1715,10 @@ simplCast env body co0 cont0 -- False: (mkTransCo co1 co2) is not fully optimised -- See Note [Avoid re-simplifying coercions] - addCoerce tyL co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = tail }) - | Just (arg_ty', m_co') <- pushCastCoTyArg co arg_ty + addCoerce tyL co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) + | Just (arg_ty', res_ty, m_co') <- pushCastCoTyArg co arg_ty = {-#SCC "addCoerce-pushCoTyArg" #-} - do { tail' <- addCoerceM hole_ty m_co' co_is_opt tail -- TODO is hole_ty right? + do { tail' <- addCoerceM res_ty m_co' co_is_opt tail ; return (ApplyToTy { sc_arg_ty = arg_ty' , sc_cont = tail' , sc_hole_ty = tyL }) } @@ -1734,9 +1734,9 @@ simplCast env body co0 cont0 | not co_is_opt -- pushCoValArg duplicates the coercion, so optimise first = addCoerce tyL (optOutCastCoercion (zapSubstEnv env) co co_is_opt) True cont - | Just (m_co1, m_co2) <- pushCastCoValArg fun_ty co -- TODO check fun_ty + | Just (_, m_co1, res_ty, m_co2) <- pushCastCoValArg tyL co = {-#SCC "addCoerce-pushCoValArg" #-} - do { tail' <- addCoerceM (funResultTy fun_ty) m_co2 co_is_opt tail -- TODO check funResultTy fun_ty + do { tail' <- addCoerceM res_ty m_co2 co_is_opt tail ; if isReflCastCo m_co1 then return (cont { sc_cont = tail' , sc_hole_ty = tyL }) ; ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -1376,7 +1376,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr | not (tickishIsCode t) = go subst floats expr cont go subst floats (Cast expr co1) (CC args m_co2) -- TODO: is the subst_ty below needed? - | Just (args', m_co1') <- pushCoArgs (subst_ty subst (exprType expr)) (subst_cast_co subst co1) args + | Just (args', _, m_co1') <- pushCoArgs (subst_ty subst (exprType expr)) (subst_cast_co subst co1) args -- See Note [Push coercions in exprIsConApp_maybe] = go subst floats expr (CC args' (m_co1' `mkTransCastCo` m_co2)) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/307ee28a3679bfdece77c6868a7da89… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/307ee28a3679bfdece77c6868a7da89… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ghc-9.12-fix-wasm] docs: add wasm related items in 9.12.3 notes
by Cheng Shao (＠TerrorJack) 25 Nov '25

25 Nov '25

Cheng Shao pushed to branch wip/ghc-9.12-fix-wasm at Glasgow Haskell Compiler / GHC Commits: 3cd27895 by Cheng Shao at 2025-11-25T14:30:05+01:00 docs: add wasm related items in 9.12.3 notes - - - - - 1 changed file: - docs/users_guide/9.12.3-notes.rst Changes: ===================================== docs/users_guide/9.12.3-notes.rst ===================================== @@ -31,6 +31,7 @@ Compiler - Fixed GHC settings to always unescape escaped spaces (:ghc-ticket:`25204`) - Fixed issue with HasCallStack constraint caching (:ghc-ticket:`25529`) - Fixed archive member size writing logic in ``GHC.SysTools.Ar`` (:ghc-ticket:`26120`, :ghc-ticket:`22586`) +- Added support for synchronous JSFFI exports for the wasm backend (:ref:`wasm-jsffi`) Runtime System ~~~~~~~~~~~~~~ @@ -46,6 +47,7 @@ Runtime System - Improved documentation of SLIDE and PACK bytecode instructions - Eliminated redundant ``SLIDE x 0`` bytecode instructions - Fixed compile issues on powerpc64 ELF v1 +- Various fixes of wasm-specific logic in the RTS Code Generation ~~~~~~~~~~~~~~~ @@ -142,5 +144,3 @@ for further change information. libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable utils/haddock/haddock-api/haddock-api.cabal: Dependency of ``haddock`` executable utils/haddock/haddock-library/haddock-library.cabal: Dependency of ``haddock`` executable - - View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3cd27895944c5f76ce606008476114e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3cd27895944c5f76ce606008476114e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/backports-9.14] rts: fix eager black holes: record mutated closure and fix assertion
by Zubin (＠wz1000) 25 Nov '25

25 Nov '25

Zubin pushed to branch wip/backports-9.14 at Glasgow Haskell Compiler / GHC Commits: bcc68c56 by Luite Stegeman at 2025-11-25T18:23:46+05:30 rts: fix eager black holes: record mutated closure and fix assertion This fixes two problems with handling eager black holes, introduced by a1de535f762bc23d4cf23a5b1853591dda12cdc9. - the closure mutation must be recorded even for eager black holes, since the mutator has mutated it before calling threadPaused - The assertion that an unmarked eager black hole must be owned by the TSO calling threadPaused is incorrect, since multiple threads can race to claim the black hole. fixes #26495 (cherry picked from commit 3ba3d9f9db784c903ebe8fd617447ce62d30b7d3) - - - - - 1 changed file: - rts/ThreadPaused.c Changes: ===================================== rts/ThreadPaused.c ===================================== @@ -321,11 +321,12 @@ threadPaused(Capability *cap, StgTSO *tso) if(frame_info == &stg_bh_upd_frame_info) { // eager black hole: we do nothing - // it should be a black hole that we own + // it should be a black hole (but we may not own it, as another + // thread could have raced us to claim it) ASSERT(bh_info == &stg_BLACKHOLE_info || bh_info == &__stg_EAGER_BLACKHOLE_info || bh_info == &stg_CAF_BLACKHOLE_info); - ASSERT(blackHoleOwner(bh) == tso || blackHoleOwner(bh) == NULL); + } else { // lazy black hole @@ -368,13 +369,15 @@ threadPaused(Capability *cap, StgTSO *tso) // The payload of the BLACKHOLE points to the TSO RELEASE_STORE(&((StgInd *)bh)->indirectee, (StgClosure *)tso); SET_INFO_RELEASE(bh,&stg_BLACKHOLE_info); + } - // .. and we need a write barrier, since we just mutated the closure: - recordClosureMutated(cap,bh); + // We need a write barrier, since the closure was mutated (by + // threadPaused for lazy black holes, or the mutator for eager + // black holes). + recordClosureMutated(cap,bh); - // We pretend that bh has just been created. - LDV_RECORD_CREATE(bh); - } + // We pretend that bh has just been created. + LDV_RECORD_CREATE(bh); frame = (StgClosure *) ((StgUpdateFrame *)frame + 1); if (prev_was_update_frame) { View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcc68c5623d5b51c5daabbd7445edfa… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcc68c5623d5b51c5daabbd7445edfa… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/bytecode-library-combined] 2 commits: Add support for building bytecode libraries
by Matthew Pickering (＠mpickering) 25 Nov '25

25 Nov '25

Matthew Pickering pushed to branch wip/bytecode-library-combined at Glasgow Haskell Compiler / GHC Commits: 0e101049 by Matthew Pickering at 2025-11-25T12:08:04+00:00 Add support for building bytecode libraries A bytecode library is a collection of bytecode files (.gbc) and a library which combines together additional object files. A bytecode library is created by invoking GHC with the `-bytecodelib` flag. A library can be created from in-memory `ModuleByteCode` linkables or by passing `.gbc` files as arguments on the command line. Fixes #26298 - - - - - 46af8bd4 by Matthew Pickering at 2025-11-25T12:08:04+00:00 Load bytecode libraries to satisfy package dependencies This commit allows you to use a bytecode library to satisfy a package dependency when using the interpreter. If a user enables `-fprefer-byte-code`, then if a package provides a bytecode library, that will be loaded and used to satisfy the dependency. The main change is to separate the relevant parts of the `LoaderState` into external and home package byte code. Bytecode is loaded into either the home package or external part (similar to HPT/EPS split), HPT bytecode can be unloaded. External bytecode is never unloaded. The unload function has also only been called with an empty list of "stable linkables" for a long time. It has been modified to directly implement a complete unloading of the home package bytecode linkables. At the moment, the bytecode libraries are found in the "library-dirs" field from the package description. In the future when `Cabal` implements support for "bytecode-library-dirs" field, we can read the bytecode libraries from there. No changes to the Cabal submodule are necessary at the moment. Four new tests are added in testsuite/tests/cabal, which generate fake package descriptions and test loading the libraries into GHCi. Fixes #26298 - - - - - 56 changed files: - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Phases.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Session.hs - + compiler/GHC/Linker/ByteCode.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Settings.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Unit/Home/PackageTable.hs - compiler/GHC/Unit/Info.hs - compiler/GHC/Unit/State.hs - compiler/ghc.cabal.in - docs/users_guide/phases.rst - libraries/ghc-boot/GHC/Unit/Database.hs - testsuite/config/ghc - testsuite/mk/boilerplate.mk - + testsuite/tests/cabal/Bytecode.hs - + testsuite/tests/cabal/BytecodeForeign.c - + testsuite/tests/cabal/BytecodeForeign.hs - testsuite/tests/cabal/Makefile - testsuite/tests/cabal/all.T - + testsuite/tests/cabal/bytecode.pkg - + testsuite/tests/cabal/bytecode.script - + testsuite/tests/cabal/bytecode_foreign.pkg - + testsuite/tests/cabal/bytecode_foreign.script - testsuite/tests/cabal/ghcpkg03.stderr - testsuite/tests/cabal/ghcpkg03.stderr-mingw32 - testsuite/tests/cabal/ghcpkg05.stderr - testsuite/tests/cabal/ghcpkg05.stderr-mingw32 - + testsuite/tests/cabal/pkg_bytecode.stderr - + testsuite/tests/cabal/pkg_bytecode.stdout - + testsuite/tests/cabal/pkg_bytecode_foreign.stderr - + testsuite/tests/cabal/pkg_bytecode_foreign.stdout - + testsuite/tests/cabal/pkg_bytecode_with_gbc.stderr - + testsuite/tests/cabal/pkg_bytecode_with_gbc.stdout - + testsuite/tests/cabal/pkg_bytecode_with_o.stderr - + testsuite/tests/cabal/pkg_bytecode_with_o.stdout - testsuite/tests/driver/bytecode-object/Makefile - testsuite/tests/driver/bytecode-object/all.T - testsuite/tests/driver/bytecode-object/bytecode_object19.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object20.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object21.stderr - + testsuite/tests/driver/bytecode-object/bytecode_object21.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object23.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object24.stdout - utils/ghc-pkg/Main.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c1584ee5d50525b9dfc0b73c04a3c6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c1584ee5d50525b9dfc0b73c04a3c6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/amg/castz] 2 commits: WIP: avoid castCoToCo in the optimizer
by Adam Gundry (＠adamgundry) 25 Nov '25

25 Nov '25

Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC Commits: d0fbc978 by Adam Gundry at 2025-11-25T11:51:29+00:00 WIP: avoid castCoToCo in the optimizer - - - - - 87cbeb6f by Adam Gundry at 2025-11-25T11:51:29+00:00 WIP: use CastCoercion in rule matcher - - - - - 12 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/Map/Type.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/Utils.hs Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -57,6 +57,13 @@ module GHC.Core.Coercion ( castCoToCo, mkTransCastCo, mkTransCastCoCo, mkTransCoCastCo, mkSymCastCo, + mkPiCastCos, + isReflCastCo, + checkReflexiveCastCo, + coToCastCo, + mkForAllCastCo, + mkFunResCastCo, + mkFunCastCoNoFTF, -- ** Decomposition instNewTyCon_maybe, @@ -83,7 +90,7 @@ module GHC.Core.Coercion ( coToMCo, kindCoToMKindCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo, - mkFunResMCo, mkPiMCos, + mkFunResMCo, isReflMCo, checkReflexiveMCo, -- ** Coercion variables @@ -390,13 +397,10 @@ mkCastTyMCo :: Type -> MCoercion -> Type mkCastTyMCo ty MRefl = ty mkCastTyMCo ty (MCo co) = ty `mkCastTy` co -mkPiMCos :: [Var] -> MCoercion -> MCoercion -mkPiMCos _ MRefl = MRefl -mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co) - -mkFunResMCo :: Id -> MCoercionR -> MCoercionR -mkFunResMCo _ MRefl = MRefl -mkFunResMCo arg_id (MCo co) = MCo (mkFunResCo Representational arg_id co) +mkFunResMCo :: Id -> CastCoercion -> CastCoercion +mkFunResMCo _ ReflCastCo = ReflCastCo +mkFunResMCo arg_id (CCoercion co) = CCoercion (mkFunResCo Representational arg_id co) +mkFunResMCo arg_id (ZCoercion ty cos) = ZCoercion (mkFunctionType (idMult arg_id) (varType arg_id) ty) cos -- TODO check type mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion mkGReflLeftMCo r ty MRefl = mkReflCo r ty @@ -843,6 +847,17 @@ mkFunCoNoFTF r w arg_co res_co Pair argl_ty argr_ty = coercionKind arg_co Pair resl_ty resr_ty = coercionKind res_co +-- AMG TODO: more cases here, or maybe better to have a FunCo constructor of CastCoercion? +mkFunCastCoNoFTF :: HasDebugCallStack => Role -> Mult -> Type -> CastCoercion -> Type -> CastCoercion -> CastCoercion +mkFunCastCoNoFTF _ mult _ (ZCoercion arg_ty arg_cos) _ (ZCoercion res_ty res_cos) = ZCoercion (mkFunctionType mult arg_ty res_ty) (arg_cos `unionVarSet` res_cos) +mkFunCastCoNoFTF _ mult _ (ZCoercion arg_ty arg_cos) res_ty res_co = ZCoercion (mkFunctionType mult arg_ty (castCoercionRKind res_ty res_co)) (arg_cos `unionVarSet` coVarsOfCastCo res_co) +mkFunCastCoNoFTF _ mult arg_ty arg_co _ (ZCoercion res_ty res_cos) = ZCoercion (mkFunctionType mult (castCoercionRKind arg_ty arg_co) res_ty) (res_cos `unionVarSet` coVarsOfCastCo arg_co) +mkFunCastCoNoFTF r mult _ (CCoercion arg_co) _ (CCoercion res_co) = CCoercion (mkFunCoNoFTF r (multToCo mult) arg_co res_co) +mkFunCastCoNoFTF _ _ _ ReflCastCo _ ReflCastCo = ReflCastCo +mkFunCastCoNoFTF r mult _ (CCoercion arg_co) res_ty ReflCastCo = CCoercion (mkFunCoNoFTF r (multToCo mult) arg_co (mkReflCo r res_ty)) +mkFunCastCoNoFTF r mult arg_ty ReflCastCo _ (CCoercion res_co) = CCoercion (mkFunCoNoFTF r (multToCo mult) (mkReflCo r arg_ty) res_co) + + -- | Build a function 'Coercion' from two other 'Coercion's. That is, -- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@ -- or @(a => x) ~ (b => y)@, depending on the kind of @a@/@b@. @@ -969,6 +984,13 @@ mkForAllCo v visL visR kind_co co | otherwise = mk_forall_co v visL visR kind_co co +mkForAllCastCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag + -> CastCoercion -> CastCoercion +mkForAllCastCo v visL visR cco = case cco of + CCoercion co -> CCoercion (mkForAllCo v visL visR MRefl co) + ZCoercion ty cos -> ZCoercion (mkTyCoForAllTy v visL ty) cos + ReflCastCo -> ReflCastCo + -- mkForAllVisCos [tv{vis}] constructs a cast -- forall tv. res ~R# forall tv{vis} res`. -- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep @@ -1774,6 +1796,9 @@ castCoercionKind g h1 h2 mkPiCos :: Role -> [Var] -> Coercion -> Coercion mkPiCos r vs co = foldr (mkPiCo r) co vs +mkPiCastCos :: Role -> [Var] -> CastCoercion -> CastCoercion +mkPiCastCos r vs co = foldr (mkPiCastCo r) co vs + -- | Make a forall 'Coercion', where both types related by the coercion -- are quantified over the same variable. mkPiCo :: Role -> Var -> Coercion -> Coercion @@ -1787,6 +1812,16 @@ mkPiCo r v co | isTyVar v = mkHomoForAllCo v co mkFunResCo r v co | otherwise = mkFunResCo r v co +mkPiCastCo :: Role -> Var -> CastCoercion -> CastCoercion +mkPiCastCo _ _ ReflCastCo = ReflCastCo +mkPiCastCo r v (CCoercion co) = CCoercion (mkPiCo r v co) +mkPiCastCo _ v (ZCoercion ty cos) + | isTyVar v = ZCoercion (mkForAllTy (Bndr v vis) ty) cos + | otherwise = ZCoercion (mkFunctionType (idMult v) (varType v) ty) cos + where + vis = coreTyLamForAllTyFlag + + mkFunResCo :: Role -> Id -> Coercion -> Coercion -- Given res_co :: res1 ~ res2, -- mkFunResCo r m arg res_co :: (arg -> res1) ~r (arg -> res2) @@ -1797,6 +1832,13 @@ mkFunResCo role id res_co arg_co = mkReflCo role (varType id) mult = multToCo (idMult id) +mkFunResCastCo :: Role -> Id -> CastCoercion -> CastCoercion +mkFunResCastCo role id res_cco = case res_cco of + CCoercion res_co -> CCoercion (mkFunResCo role id res_co) + ZCoercion ty cos -> ZCoercion (mkFunctionType (idMult id) (varType id) ty) cos + ReflCastCo -> ReflCastCo + + -- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 -- The first coercion might be lifted or unlifted; thus the ~? above -- Lifted and unlifted equalities take different numbers of arguments, @@ -2882,7 +2924,7 @@ See Note [Zapped casts] in GHC.Core.TyCo.Rep. -- but requires the type to be supplied by the caller because it cannot be -- recovered in the 'ZCoercion' case. castCoercionLKind :: HasDebugCallStack => Type -> CastCoercion -> Type -castCoercionLKind _ (CCoercion co) = coercionLKind co +castCoercionLKind _ (CCoercion co) = coercionLKind co -- TODO: should we use provided lhs_ty instead? Not sure which is cheaper? castCoercionLKind lhs_ty (ZCoercion _ _) = lhs_ty castCoercionLKind lhs_ty ReflCastCo = lhs_ty @@ -2931,9 +2973,27 @@ mkTransCoCastCo co1 (CCoercion co2) = CCoercion (mkTransCo co1 co2) mkTransCoCastCo co1 (ZCoercion ty cos) = ZCoercion ty (shallowCoVarsOfCo co1 `unionVarSet` cos) mkTransCoCastCo co1 ReflCastCo = CCoercion co1 +-- | Quickly check if a 'CastCoercion' is obviously reflexive. +isReflCastCo :: CastCoercion -> Bool +isReflCastCo (CCoercion co) = isReflCo co +isReflCastCo ZCoercion{} = False -- it might be, but we can't tell +isReflCastCo ReflCastCo = True + -- | Slowly checks if the coercion is reflexive. Don't call this in a loop, -- as it walks over the entire coercion. isReflexiveCastCo :: Type -> CastCoercion -> Bool isReflexiveCastCo _ (CCoercion co) = isReflexiveCo co isReflexiveCastCo lhs_ty (ZCoercion rhs_ty _) = lhs_ty `eqType` rhs_ty isReflexiveCastCo _ ReflCastCo = True + +checkReflexiveCastCo :: Type -> CastCoercion -> CastCoercion +checkReflexiveCastCo ty cco + | isReflexiveCastCo ty cco = ReflCastCo + | otherwise = cco + +coToCastCo :: Coercion -> CastCoercion +-- Convert a coercion to a CastCoercion, checking if it is obviously reflexive. +-- It's not clear whether or not isReflexiveCo would be better here +-- See #19815 for a bit of data and discussion on this point +coToCastCo co | isReflCo co = ReflCastCo + | otherwise = CCoercion co ===================================== compiler/GHC/Core/Coercion/Opt.hs ===================================== @@ -4,6 +4,7 @@ module GHC.Core.Coercion.Opt ( optCoercion + , optCastCoercion , OptCoercionOpts (..) ) where @@ -169,6 +170,13 @@ newtype OptCoercionOpts = OptCoercionOpts { optCoercionEnabled :: Bool -- ^ Enable coercion optimisation (reduce its size) } +optCastCoercion :: OptCoercionOpts -> Subst -> Type -> CastCoercion -> CastCoercion +optCastCoercion _ _ _ ReflCastCo = ReflCastCo +optCastCoercion opts env _ (CCoercion co) = CCoercion (optCoercion opts env co) +optCastCoercion _ env tyL (ZCoercion tyR cos) + | tyL `eqTypeIgnoringMultiplicity` tyR = ReflCastCo + | otherwise = ZCoercion (substTy env tyR) (substCoVarSet env cos) + optCoercion :: OptCoercionOpts -> Subst -> Coercion -> NormalCo -- ^ optCoercion applies a substitution to a coercion, -- *and* optimises it to reduce its size ===================================== compiler/GHC/Core/Map/Type.hs ===================================== @@ -139,6 +139,7 @@ xtC (D env co) f (CoercionMapX m) -- We should really never care about the contents of a cast coercion. Instead, -- just look up the coercion's RHS type. +-- TODO: do we need this type, or can we just use TypeMap? newtype CastCoercionMap a = CastCoercionMap (CastCoercionMapG a) -- TODO(22292): derive ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -42,7 +42,7 @@ module GHC.Core.Opt.Arity , etaExpandToJoinPoint, etaExpandToJoinPointRule -- ** Coercions and casts - , pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg + , pushCoArg, pushCoArgs, pushCastCoValArg, pushCastCoTyArg , pushCoercionIntoLambda, pushCoDataCon, collectBindersPushingCo ) where @@ -2195,7 +2195,7 @@ Now, when we push that eta_co inward in etaInfoApp: -} -------------- -data EtaInfo = EI [Var] MCoercionR +data EtaInfo = EI [Var] CastCoercion -- See Note [The EtaInfo mechanism] instance Outputable EtaInfo where @@ -2221,11 +2221,10 @@ etaInfoApp in_scope expr eis go subst (Tick t e) eis = Tick (substTickish subst t) (go subst e eis) - go subst (Cast e cco) (EI bs mco) + go subst (Cast e co) (EI bs mco) = go subst e (EI bs mco') where - co = castCoToCo (exprType e) cco -- TODO: can we avoid this? - mco' = checkReflexiveMCo (Core.substCo subst co `mkTransMCoR` mco) + mco' = checkReflexiveCastCo (exprType (Core.substExpr subst e)) (Core.substCastCo subst co `mkTransCastCo` mco) -- See Note [Check for reflexive casts in eta expansion] go subst (Case e b ty alts) eis @@ -2247,13 +2246,13 @@ etaInfoApp in_scope expr eis -- Beta-reduction if possible, pushing any intervening casts past -- the argument. See Note [The EtaInfo mechanism] go subst (Lam v e) (EI (b:bs) mco) - | Just (arg,mco') <- pushMCoArg mco (varToCoreExpr b) + | Just (arg,mco') <- pushCoArg (exprType (Lam v e)) mco (varToCoreExpr b) = go (Core.extendSubst subst v arg) e (EI bs mco') -- Stop pushing down; just wrap the expression up -- See Note [Check for reflexive casts in eta expansion] go subst e (EI bs mco) = Core.substExprSC subst e - `mkCastMCo` checkReflexiveMCo mco + `mkCastCo` checkReflexiveCastCo (exprType e) mco -- TODO check type `mkVarApps` bs -------------- @@ -2263,14 +2262,12 @@ etaInfoAppTy :: Type -> EtaInfo -> Type etaInfoAppTy ty (EI bs mco) = applyTypeToArgs ty1 (map varToCoreExpr bs) where - ty1 = case mco of - MRefl -> ty - MCo co -> coercionRKind co + ty1 = castCoercionRKind ty mco -------------- etaInfoAbs :: EtaInfo -> CoreExpr -> CoreExpr -- See Note [The EtaInfo mechanism] -etaInfoAbs (EI bs mco) expr = (mkLams bs expr) `mkCastMCo` mkSymMCo mco +etaInfoAbs (EI bs mco) expr = (mkLams bs expr) `mkCastCo` mkSymCastCo (error "AMG TODO: etaInfoAbs") mco -------------- -- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding @@ -2307,7 +2304,7 @@ mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty go _ [] subst _ ----------- Done! No more expansion needed - = (substInScopeSet subst, EI [] MRefl) + = (substInScopeSet subst, EI [] ReflCastCo) go n oss@(one_shot:oss1) subst ty ----------- Forall types (forall a. ty) @@ -2348,27 +2345,28 @@ mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty -- we'd have had to zap it for the recursive call) , (in_scope, EI bs mco) <- go n oss subst ty' -- mco :: subst(ty') ~ b1_ty -> ... -> bn_ty -> tr - = (in_scope, EI bs (mkTransMCoR co' mco)) + = (in_scope, EI bs (mkTransCoCastCo co' mco)) | otherwise -- We have an expression of arity > 0, -- but its type isn't a function, or a binder -- does not have a fixed runtime representation = warnPprTrace True "mkEtaWW" ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr) - (substInScopeSet subst, EI [] MRefl) + (substInScopeSet subst, EI [] ReflCastCo) -- This *can* legitimately happen: -- e.g. coerce Int (\x. x) Essentially the programmer is -- playing fast and loose with types (Happy does this a lot). -- So we simply decline to eta-expand. Otherwise we'd end up -- with an explicit lambda having a non-function type -mkEtaForAllMCo :: ForAllTyBinder -> Type -> MCoercion -> MCoercion +mkEtaForAllMCo :: ForAllTyBinder -> Type -> CastCoercion -> CastCoercion mkEtaForAllMCo (Bndr tcv vis) ty mco = case mco of - MRefl | vis == coreTyLamForAllTyFlag -> MRefl - | otherwise -> mk_fco (mkRepReflCo ty) - MCo co -> mk_fco co + ReflCastCo | vis == coreTyLamForAllTyFlag -> ReflCastCo + | otherwise -> mk_fco (mkRepReflCo ty) + CCoercion co -> mk_fco co + ZCoercion _ty2 cos -> ZCoercion ty cos -- TODO: is ty right? where - mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag MRefl co) + mk_fco co = CCoercion (mkForAllCo tcv vis coreTyLamForAllTyFlag MRefl co) -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly -- the (EtaInfo Invariant). (sym co) wraps a lambda that always has -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core] @@ -2701,13 +2699,13 @@ same fix. tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> SubDemand -> Maybe CoreExpr -- Return an expression equal to (\bndrs. body) tryEtaReduce rec_ids bndrs body eval_sd - = go (reverse bndrs) body (mkRepReflCo (exprType body)) + = go (reverse bndrs) body ReflCastCo where incoming_arity = count isId bndrs -- See Note [Eta reduction makes sense], point (2) go :: [Var] -- Binders, innermost first, types [a3,a2,a1] -> CoreExpr -- Of type tr - -> Coercion -- Of type tr ~ ts + -> CastCoercion -- Of type tr ~ ts -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts -- See Note [Eta reduction with casted arguments] -- for why we have an accumulating coercion @@ -2717,7 +2715,7 @@ tryEtaReduce rec_ids bndrs body eval_sd -- See Note [Eta reduction with casted function] go bs (Cast e co1) co2 - = go bs e (castCoToCo (exprType e) co1 `mkTransCo` co2) + = go bs e (co1 `mkTransCastCo` co2) go bs (Tick t e) co | tickishFloatable t @@ -2740,7 +2738,7 @@ tryEtaReduce rec_ids bndrs body eval_sd , remaining_bndrs `ltLength` bndrs -- Only reply Just if /something/ has happened , ok_fun fun - , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co + , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCastCo co reduced_bndrs = mkVarSet (dropList remaining_bndrs bndrs) -- reduced_bndrs are the ones we are eta-reducing away , used_vars `disjointVarSet` reduced_bndrs @@ -2749,7 +2747,7 @@ tryEtaReduce rec_ids bndrs body eval_sd -- See Note [Eta reduction makes sense], intro and point (1) -- NB: don't compute used_vars from exprFreeVars (mkCast fun co) -- because the latter may be ill formed if the guard fails (#21801) - = Just (mkLams (reverse remaining_bndrs) (mkCast fun co)) + = Just (mkLams (reverse remaining_bndrs) (mkCastCo fun co)) go _remaining_bndrs _fun _ = -- pprTrace "tER fail" (ppr _fun $$ ppr _remaining_bndrs) $ Nothing @@ -2797,10 +2795,10 @@ tryEtaReduce rec_ids bndrs body eval_sd --------------- ok_arg :: Var -- Of type bndr_t -> CoreExpr -- Of type arg_t - -> Coercion -- Of kind (t1~t2) + -> CastCoercion -- Of kind (t1~t2) -> Type -- Type (arg_t -> t1) of the function -- to which the argument is supplied - -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) + -> Maybe (CastCoercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) -- (and similarly for tyvars, coercion args) , [CoreTickish]) -- See Note [Eta reduction with casted arguments] @@ -2808,7 +2806,7 @@ tryEtaReduce rec_ids bndrs body eval_sd | Just tv <- getTyVar_maybe arg_ty , bndr == tv = case splitForAllForAllTyBinder_maybe fun_ty of Just (Bndr _ vis, _) -> Just (fco, []) - where !fco = mkForAllCo tv vis coreTyLamForAllTyFlag MRefl co + where !fco = mkForAllCastCo tv vis coreTyLamForAllTyFlag co -- The lambda we are eta-reducing always has visibility -- 'coreTyLamForAllTyFlag' which may or may not match -- the visibility on the inner function (#24014) @@ -2821,13 +2819,13 @@ tryEtaReduce rec_ids bndrs body eval_sd , let mult = idMult bndr , Just (_af, fun_mult, _, _) <- splitFunTy_maybe fun_ty , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort - = Just (mkFunResCo Representational bndr co, []) + = Just (mkFunResCastCo Representational bndr co, []) ok_arg bndr (Cast e co_arg) co fun_ty | (ticks, Var v) <- stripTicksTop tickishFloatable e - , Just (_, fun_mult, _, _) <- splitFunTy_maybe fun_ty + , Just (_, fun_mult, _, res_ty) <- splitFunTy_maybe fun_ty , bndr == v , fun_mult `eqType` idMult bndr - = Just (mkFunCoNoFTF Representational (multToCo fun_mult) (mkSymCo (castCoToCo (exprType e) co_arg)) co, ticks) + = Just (mkFunCastCoNoFTF Representational fun_mult (castCoercionRKind (exprType e) co_arg) (mkSymCastCo (exprType e) co_arg) res_ty co, ticks) -- TODO check types -- The simplifier combines multiple casts into one, -- so we can have a simple-minded pattern match here ok_arg bndr (Tick t arg) co fun_ty @@ -2873,43 +2871,44 @@ Here we implement the "push rules" from FC papers: by pushing the coercion into the arguments -} -pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion) -pushCoArgs co [] = return ([], MCo co) -pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg - ; case m_co1 of - MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args - ; return (arg':args', m_co2) } - MRefl -> return (arg':args, MRefl) } - -pushMCoArg :: MCoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) -pushMCoArg MRefl arg = Just (arg, MRefl) -pushMCoArg (MCo co) arg = pushCoArg co arg - -pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) +pushCoArgs :: Type -> CastCoercion -> [CoreArg] -> Maybe ([CoreArg], CastCoercion) +pushCoArgs _ co [] = return ([], co) +pushCoArgs fun_ty co (arg:args) = do + { (arg', m_co1) <- pushCoArg fun_ty co arg + ; if isReflCastCo m_co1 + then return (arg':args, ReflCastCo) + else do { (args', m_co2) <- pushCoArgs (funResultTy fun_ty) m_co1 args -- TODO check type + ; return (arg':args', m_co2) } + } + +pushCoArg :: Type -> CastCoercion -> CoreArg -> Maybe (CoreArg, CastCoercion) -- We have (fun |> co) arg, and we want to transform it to -- (fun arg) |> co -- This may fail, e.g. if (fun :: N) where N is a newtype -- C.f. simplCast in GHC.Core.Opt.Simplify -- 'co' is always Representational -pushCoArg co arg +pushCoArg fun_ty co arg | Type ty <- arg - = do { (ty', m_co') <- pushCoTyArg co ty + = do { (ty', m_co') <- pushCastCoTyArg co ty ; return (Type ty', m_co') } | otherwise - = do { (arg_mco, m_co') <- pushCoValArg co - ; let arg_mco' = checkReflexiveMCo arg_mco - -- checkReflexiveMCo: see Note [Check for reflexive casts in eta expansion] + = do { (arg_mco, m_co') <- pushCastCoValArg fun_ty co + ; let arg_mco' = checkReflexiveCastCo (funArgTy fun_ty) arg_mco + -- checkReflexiveCastCo: see Note [Check for reflexive casts in eta expansion] -- The coercion is very often (arg_co -> res_co), but without -- the argument coercion actually being ReflCo - ; return (arg `mkCastMCo` arg_mco', m_co') } + ; return (arg `mkCastCo` arg_mco', m_co') } + +pushCastCoTyArg :: CastCoercion -> Type -> Maybe (Type, CastCoercion) +pushCastCoTyArg (CCoercion co) ty = pushCoTyArg co ty +pushCastCoTyArg ReflCastCo ty = Just (ty, ReflCastCo) +pushCastCoTyArg (ZCoercion _fun_ty _cos) _ty = Nothing -- TODO do better -pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR) +pushCoTyArg :: CoercionR -> Type -> Maybe (Type, CastCoercion) -- We have (fun |> co) @ty -- Push the coercion through to return -- (fun @ty') |> co' -- 'co' is always Representational --- If the returned coercion is Nothing, then it would have been reflexive; --- it's faster not to compute it, though. pushCoTyArg co ty -- The following is inefficient - don't do `eqType` here, the coercion -- optimizer will take care of it. See #14737. @@ -2917,11 +2916,11 @@ pushCoTyArg co ty -- -- = Just (ty, Nothing) | isReflCo co - = Just (ty, MRefl) + = Just (ty, ReflCastCo) | isForAllTy_ty tyL = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $ - Just (ty `mkCastTy` co1, MCo co2) + Just (ty `mkCastTy` co1, CCoercion co2) | otherwise = Nothing @@ -2941,6 +2940,18 @@ pushCoTyArg co ty -- co2 :: ty1[ (ty|>co1)/a1 ] ~R ty2[ ty/a2 ] -- Arg of mkInstCo is always nominal, hence Nominal +pushCastCoValArg :: Type -> CastCoercion -> Maybe (CastCoercion, CastCoercion) +pushCastCoValArg _ ReflCastCo = Just (ReflCastCo, ReflCastCo) +pushCastCoValArg _ (CCoercion co) = pushCoValArg co +pushCastCoValArg tyL (ZCoercion tyR cos) + | isFunTy tyL -- TODO: do we need to check this or can we assume it? + , isFunTy tyR + , typeHasFixedRuntimeRep new_arg_ty + = Just (ZCoercion new_arg_ty cos, ZCoercion (funResultTy tyR) cos) + | otherwise = Nothing + where + new_arg_ty = funArgTy tyR + -- | If @pushCoValArg co = Just (co_arg, co_res)@, then -- -- > (\x.body) |> co = (\y. let { x = y |> co_arg } in body) |> co_res) @@ -2952,7 +2963,7 @@ pushCoTyArg co ty -- If the LHS is well-typed, then so is the RHS. In particular, the argument -- @arg |> co_arg@ is guaranteed to have a fixed 'RuntimeRep', in the sense of -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR) +pushCoValArg :: CoercionR -> Maybe (CastCoercion, CastCoercion) pushCoValArg co -- The following is inefficient - don't do `eqType` here, the coercion -- optimizer will take care of it. See #14737. @@ -2960,7 +2971,7 @@ pushCoValArg co -- -- = Just (mkRepReflCo arg, Nothing) | isReflCo co - = Just (MRefl, MRefl) + = Just (ReflCastCo, ReflCastCo) | isFunTy tyL , (_, co1, co2) <- decomposeFunCo co @@ -2979,8 +2990,8 @@ pushCoValArg co (vcat [ text "co:" <+> ppr co , text "old_arg_ty:" <+> ppr old_arg_ty , text "new_arg_ty:" <+> ppr new_arg_ty ]) $ - Just (coToMCo (mkSymCo co1), coToMCo co2) - -- Critically, coToMCo to checks for ReflCo; the whole coercion may not + Just (coToCastCo (mkSymCo co1), coToCastCo co2) + -- Critically, coToCastCo to checks for ReflCo; the whole coercion may not -- be reflexive, but either of its components might be -- We could use isReflexiveCo, but it's not clear if the benefit -- is worth the cost, and it makes no difference in #18223 @@ -2993,13 +3004,14 @@ pushCoValArg co Pair tyL tyR = coercionKind co pushCoercionIntoLambda - :: HasDebugCallStack => Subst -> InVar -> InExpr -> OutCoercionR -> Maybe (OutVar, OutExpr) + :: HasDebugCallStack => Subst -> InVar -> InExpr -> OutCastCoercion -> Maybe (OutVar, OutExpr) -- This implements the Push rule from the paper on coercions -- (\x. e) |> co -- ===> -- (\x'. e |> co') -pushCoercionIntoLambda subst x e co +pushCoercionIntoLambda subst x e cco | assert (not (isTyVar x) && not (isCoVar x)) True + , CCoercion co <- cco -- AMG TODO: support for other CastCoercions , Pair s1s2 t1t2 <- coercionKind co , Just {} <- splitFunTy_maybe s1s2 , Just (_, w1, t1,_t2) <- splitFunTy_maybe t1t2 @@ -3024,7 +3036,7 @@ pushCoercionIntoLambda subst x e co | otherwise = Nothing -pushCoDataCon :: DataCon -> [CoreExpr] -> MCoercionR +pushCoDataCon :: DataCon -> [CoreExpr] -> CastCoercion -> Maybe (DataCon , [Type] -- Universal type args , [CoreExpr]) -- All other args incl existentials @@ -3034,8 +3046,9 @@ pushCoDataCon :: DataCon -> [CoreExpr] -> MCoercionR -- where co :: (T t1 .. tn) ~ (T s1 .. sn) -- The left-hand one must be a T, because exprIsConApp returned True -- but the right-hand one might not be. (Though it usually will.) -pushCoDataCon dc dc_args MRefl = Just $! (push_dc_refl dc dc_args) -pushCoDataCon dc dc_args (MCo co) = push_dc_gen dc dc_args co (coercionKind co) +pushCoDataCon dc dc_args ReflCastCo = Just $! (push_dc_refl dc dc_args) +pushCoDataCon dc dc_args (CCoercion co) = push_dc_gen dc dc_args co (coercionKind co) +pushCoDataCon _dc _dc_args (ZCoercion _ty _cos) = Nothing -- AMG TODO: pushCoDataCon push_dc_refl :: DataCon -> [CoreExpr] -> (DataCon, [Type], [CoreExpr]) push_dc_refl dc dc_args ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -36,11 +36,11 @@ import GHC.Prelude hiding ( head, init, last, tail ) import GHC.Core import GHC.Core.FVs import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, - mkCastMCo, mkTicks ) + mkCastCo, mkTicks ) import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr ) import GHC.Core.Coercion import GHC.Core.Type -import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo, coVarsOfCastCo ) +import GHC.Core.TyCo.FVs ( coVarsOfCastCo ) import GHC.Data.Maybe( orElse ) import GHC.Data.Graph.Directed ( SCC(..), Node(..) @@ -2853,7 +2853,7 @@ data OccEnv -- If x :-> (y, co) is in the env, -- then please replace x by (y |> mco) -- Invariant of course: idType x = exprType (y |> mco) - , occ_bs_env :: !(IdEnv (OutId, MCoercion)) + , occ_bs_env :: !(IdEnv (OutId, CastCoercion)) -- Domain is Global and Local Ids -- Range is just Local Ids , occ_bs_rng :: !VarSet @@ -3455,7 +3455,7 @@ addBndrSwap scrut case_bndr -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco) , occ_bs_rng = rng_vars `extendVarSet` case_bndr' - `unionVarSet` tyCoVarsOfMCo mco } + `unionVarSet` tyCoVarsOfCastCo mco } | otherwise = env @@ -3466,7 +3466,7 @@ addBndrSwap scrut case_bndr -- | See bBinderSwaOk. data BinderSwapDecision = NoBinderSwap - | DoBinderSwap OutVar MCoercion + | DoBinderSwap OutVar CastCoercion scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision -- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then @@ -3479,8 +3479,8 @@ scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision scrutOkForBinderSwap e = case e of Tick _ e -> scrutOkForBinderSwap e -- Drop ticks - Var v -> DoBinderSwap v MRefl - Cast (Var v) co -> DoBinderSwap v (MCo (mkSymCo (castCoToCo (idType v) co))) -- TODO: can we do better? + Var v -> DoBinderSwap v ReflCastCo + Cast (Var v) co -> DoBinderSwap v (mkSymCastCo (idType v) co) -- Cast: see Note [Case of cast] _ -> NoBinderSwap @@ -3495,7 +3495,7 @@ lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env }) bndr -- Why do we iterate here? -- See (BS2) in Note [The binder-swap substitution] case lookupBndrSwap env bndr1 of - (fun, fun_id) -> (mkCastMCo fun mco, fun_id) } + (fun, fun_id) -> (mkCastCo fun mco, fun_id) } {- Historical note [Proxy let-bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -19,6 +19,7 @@ import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.ConstantFold import GHC.Core.Type hiding ( substCo, substTy, substTyVar, extendTvSubst, extendCvSubst ) import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCo.Subst ( substCoVarSet ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Inline import GHC.Core.Opt.Simplify.Utils @@ -36,7 +37,7 @@ import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe - , pushCoTyArg, pushCoValArg, exprIsDeadEnd + , pushCastCoTyArg, pushCastCoValArg, exprIsDeadEnd , typeArity, arityTypeArity, etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo {- exprsFreeIds -} ) @@ -54,6 +55,7 @@ import GHC.Types.Unique ( hasKey ) import GHC.Types.Basic import GHC.Types.Tickish import GHC.Types.Var ( isTyCoVar ) +import GHC.Types.Var.Set import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey, seqHashKey ) @@ -1361,6 +1363,15 @@ simplCoercion env co subst = getTCvSubst env opts = seOptCoercionOpts env +simplCastCoercion :: SimplEnv -> InType -> InCastCoercion -> SimplM (OutType, OutCastCoercion) +simplCastCoercion env _ (CCoercion co) = (\co -> (coercionLKind co, CCoercion co)) <$> simplCoercion env co +simplCastCoercion env tyL (ZCoercion tyR cos) = (,) <$> simplType env tyL <*> (ZCoercion <$> simplType env tyR <*> simplCoVars env cos) +simplCastCoercion env tyL ReflCastCo = (,) <$> simplType env tyL <*> pure ReflCastCo + +simplCoVars :: SimplEnv -> CoVarSet -> SimplM CoVarSet +simplCoVars env covars = pure $ substCoVarSet (getTCvSubst env) covars + + ----------------------------------- -- | Push a TickIt context outwards past applications and cases, as -- long as this is a non-scoping tick, to let case and application @@ -1531,10 +1542,10 @@ rebuild_go env expr cont Stop {} -> return (emptyFloats env, expr) TickIt t cont -> rebuild_go env (mkTick t expr) cont CastIt { sc_co = co, sc_opt = opt, sc_cont = cont } - -> rebuild_go env (mkCast expr co') cont + -> rebuild_go env (mkCastCo expr co') cont -- NB: mkCast implements the (Coercion co |> g) optimisation where - co' = optOutCoercion env co opt + co' = optOutCastCoercion env co opt Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont @@ -1663,6 +1674,12 @@ on each successive composition -- that's at least quadratic. So: -} +optOutCastCoercion :: SimplEnvIS -> OutCastCoercion -> Bool -> OutCastCoercion +optOutCastCoercion env cco already_optimised = case cco of + ReflCastCo -> ReflCastCo + CCoercion co -> CCoercion (optOutCoercion env co already_optimised) + ZCoercion{} -> cco + optOutCoercion :: SimplEnvIS -> OutCoercion -> Bool -> OutCoercion -- See Note [Avoid re-simplifying coercions] optOutCoercion env co already_optimised @@ -1675,72 +1692,74 @@ optOutCoercion env co already_optimised simplCast :: SimplEnv -> InExpr -> InCastCoercion -> SimplCont -> SimplM (SimplFloats, OutExpr) simplCast env body co0 cont0 - = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env (castCoToCo (exprType body) co0) -- TODO better way? + = do { (tyL, co1) <- {-#SCC "simplCast-simplCoercion" #-} simplCastCoercion env (exprType body) co0 ; cont1 <- {-#SCC "simplCast-addCoerce" #-} - if isReflCo co1 + if isReflCastCo co1 then return cont0 -- See Note [Optimising reflexivity] - else addCoerce co1 True cont0 + else addCoerce tyL co1 True cont0 -- True <=> co1 is optimised ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } where -- If the first parameter is MRefl, then simplifying revealed a -- reflexive coercion. Omit. - addCoerceM :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont - addCoerceM MRefl _ cont = return cont - addCoerceM (MCo co) opt cont = addCoerce co opt cont - - addCoerce :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont - addCoerce co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity] - = addCoerce (mkTransCo co1 co2) False cont + -- TODO: probably can simplify this further now? + addCoerceM :: OutType -> OutCastCoercion -> Bool -> SimplCont -> SimplM SimplCont + addCoerceM _ ReflCastCo _ cont = return cont + addCoerceM tyL co opt cont = addCoerce tyL co opt cont + + -- Type tyL is the coercionLKind of the coercion + addCoerce :: OutType -> OutCastCoercion -> Bool -> SimplCont -> SimplM SimplCont + addCoerce tyL co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity] + = addCoerce tyL (mkTransCastCo co1 co2) False cont -- False: (mkTransCo co1 co2) is not fully optimised -- See Note [Avoid re-simplifying coercions] - addCoerce co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) - | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty + addCoerce tyL co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = tail }) + | Just (arg_ty', m_co') <- pushCastCoTyArg co arg_ty = {-#SCC "addCoerce-pushCoTyArg" #-} - do { tail' <- addCoerceM m_co' co_is_opt tail + do { tail' <- addCoerceM hole_ty m_co' co_is_opt tail -- TODO is hole_ty right? ; return (ApplyToTy { sc_arg_ty = arg_ty' , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } + , sc_hole_ty = tyL }) } -- NB! As the cast goes past, the -- type of the hole changes (#16312) -- (f |> co) e ===> (f (e |> co1)) |> co2 -- where co :: (s1->s2) ~ (t1->t2) -- co1 :: t1 ~ s1 -- co2 :: s2 ~ t2 - addCoerce co co_is_opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se + addCoerce tyL co co_is_opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_dup = dup, sc_cont = tail , sc_hole_ty = fun_ty }) | not co_is_opt -- pushCoValArg duplicates the coercion, so optimise first - = addCoerce (optOutCoercion (zapSubstEnv env) co co_is_opt) True cont + = addCoerce tyL (optOutCastCoercion (zapSubstEnv env) co co_is_opt) True cont - | Just (m_co1, m_co2) <- pushCoValArg co + | Just (m_co1, m_co2) <- pushCastCoValArg fun_ty co -- TODO check fun_ty = {-#SCC "addCoerce-pushCoValArg" #-} - do { tail' <- addCoerceM m_co2 co_is_opt tail - ; case m_co1 of { - MRefl -> return (cont { sc_cont = tail' - , sc_hole_ty = coercionLKind co }) ; + do { tail' <- addCoerceM (funResultTy fun_ty) m_co2 co_is_opt tail -- TODO check funResultTy fun_ty + ; if isReflCastCo m_co1 + then return (cont { sc_cont = tail' + , sc_hole_ty = tyL }) ; -- See Note [Avoiding simplifying repeatedly] - MCo co1 -> + else do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing arg_se arg -- When we build the ApplyTo we can't mix the OutCoercion -- 'co' with the InExpr 'arg', so we simplify -- to make it all consistent. It's a bit messy. -- But it isn't a common case. -- Example of use: #995 - ; return (ApplyToVal { sc_arg = mkCast arg' co1 + ; return (ApplyToVal { sc_arg = mkCastCo arg' m_co1 , sc_env = arg_se' , sc_dup = dup' , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } } } + , sc_hole_ty = tyL }) } } - addCoerce co co_is_opt cont - | isReflCo co = return cont -- Having this at the end makes a huge + addCoerce tyL co co_is_opt cont + | isReflCastCo co = return cont -- Having this at the end makes a huge -- difference in T12227, for some reason -- See Note [Optimising reflexivity] - | otherwise = return (CastIt { sc_co = co, sc_opt = co_is_opt, sc_cont = cont }) + | otherwise = return (CastIt { sc_co = co, sc_hole_ty = tyL, sc_opt = co_is_opt, sc_cont = cont }) simplLazyArg :: SimplEnvIS -- ^ Used only for its InScopeSet -> DupFlag @@ -3595,9 +3614,9 @@ addAltUnfoldings env case_bndr bndr_swap con_app -- See Note [Add unfolding for scrutinee] env2 | DoBinderSwap v mco <- bndr_swap = addBinderUnfolding env1 v $ - if isReflMCo mco -- isReflMCo: avoid calling mk_simple_unf + if isReflCastCo mco -- isReflCastCo: avoid calling mk_simple_unf then con_app_unf -- twice in the common case - else mk_simple_unf (mkCastMCo con_app mco) + else mk_simple_unf (mkCastCo con_app mco) | otherwise = env1 @@ -3865,9 +3884,10 @@ mkDupableContWithDmds env _ cont mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn -mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }) +mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_hole_ty = ty, sc_opt = opt, sc_cont = cont }) = do { (floats, cont') <- mkDupableContWithDmds env dmds cont - ; return (floats, CastIt { sc_co = optOutCoercion env co opt + ; return (floats, CastIt { sc_co = optOutCastCoercion env co opt + , sc_hole_ty = ty , sc_opt = True, sc_cont = cont' }) } -- optOutCoercion: see Note [Avoid re-simplifying coercions] ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -52,7 +52,7 @@ import GHC.Core.Opt.Simplify.Inline( smallEnoughToInline ) import GHC.Core.Opt.Stats ( Tick(..) ) import qualified GHC.Core.Subst import GHC.Core.Ppr -import GHC.Core.TyCo.Ppr ( pprParendType ) +import GHC.Core.TyCo.Ppr ( pprParendType, pprCastCo ) import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Opt.Arity @@ -162,8 +162,9 @@ data SimplCont | CastIt -- (CastIt co K)[e] = K[ e `cast` co ] - { sc_co :: OutCoercion -- The coercion simplified + { sc_co :: OutCastCoercion -- The coercion simplified -- Invariant: never an identity coercion + , sc_hole_ty :: OutType -- LHS kind of sc_co , sc_opt :: Bool -- True <=> sc_co has had optCoercion applied to it -- See Note [Avoid re-simplifying coercions] -- in GHC.Core.Opt.Simplify.Iteration @@ -277,7 +278,7 @@ instance Outputable SimplCont where where pps = [ppr interesting] ++ [ppr eval_sd | eval_sd /= topSubDmd] ppr (CastIt { sc_co = co, sc_cont = cont }) - = (text "CastIt" <+> pprOptCo co) $$ ppr cont + = (text "CastIt" <+> pprCastCo co) $$ ppr cont ppr (TickIt t cont) = (text "TickIt" <+> ppr t) $$ ppr cont ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) @@ -474,7 +475,7 @@ contResultType (TickIt _ k) = contResultType k contHoleType :: SimplCont -> OutType contHoleType (Stop ty _ _) = ty contHoleType (TickIt _ k) = contHoleType k -contHoleType (CastIt { sc_co = co }) = coercionLKind co +contHoleType (CastIt { sc_hole_ty = ty }) = ty contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se }) = perhapsSubstTy dup se (idType b) contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty @@ -1896,7 +1897,7 @@ rebuildLam env bndrs@(bndr:_) body cont | -- Note [Casts and lambdas] seCastSwizzle env , not (any bad bndrs) - = mkCast (mk_lams bndrs body) (mkPiCos Representational bndrs (castCoToCo (exprType body) co)) + = mkCastCo (mk_lams bndrs body) (mkPiCastCos Representational bndrs co) where co_vars = tyCoVarsOfCastCo co bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -1120,7 +1120,7 @@ extendCaseBndrs env scrut case_bndr con alt_bndrs where live_case_bndr = not (isDeadBinder case_bndr) env1 | DoBinderSwap v mco <- scrutOkForBinderSwap scrut - , isReflMCo mco = extendValEnv env v cval + , isReflCastCo mco = extendValEnv env v cval | otherwise = env -- See Note [Add scrutinee to ValueEnv too] env2 | live_case_bndr = extendValEnv env1 case_bndr cval | otherwise = env1 ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -52,13 +52,14 @@ import GHC.Core.FVs ( exprFreeVars, bindFreeVars , rulesFreeVarsDSet, orphNamesOfExprs ) import GHC.Core.Utils ( exprType, mkTick, mkTicks , stripTicksTopT, stripTicksTopE - , isJoinBind, mkCastMCo ) + , isJoinBind, mkCastCo ) import GHC.Core.Ppr ( pprRules ) import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Core.Type as Type ( Type, extendTvSubst, extendCvSubst , substTy, getTyVar_maybe ) import GHC.Core.TyCo.Ppr( pprParendType ) +import GHC.Core.TyCo.FVs ( tyCoFVsOfCastCoercion ) import GHC.Core.Coercion as Coercion import GHC.Core.Tidy ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr ) @@ -815,7 +816,7 @@ match_exprs :: HasDebugCallStack match_exprs _ subst [] _ = Just subst match_exprs renv subst (e1:es1) (e2:es2) - = do { subst' <- match renv subst e1 e2 MRefl + = do { subst' <- match renv subst e1 e2 ReflCastCo ; match_exprs renv subst' es1 es2 } match_exprs _ _ _ _ = Nothing @@ -1065,7 +1066,7 @@ match :: HasDebugCallStack -> RuleSubst -- Substitution applies to template only -> CoreExpr -- Template -> CoreExpr -- Target - -> MCoercion + -> CastCoercion -> Maybe RuleSubst -- Postcondition (TypeInv): if matching succeeds, then @@ -1102,8 +1103,8 @@ match renv subst (Type ty1) (Type ty2) _mco ------------------------ Coercions --------------------- -- See Note [Coercion arguments] for why this isn't really right -match renv subst (Coercion co1) (Coercion co2) MRefl - = match_co renv subst co1 co2 +match renv subst (Coercion co1) (Coercion co2) ReflCastCo + = match_co renv subst (CCoercion co1) (CCoercion co2) -- TODO should probably have match_cast_co and match_co separately? -- The MCo case corresponds to matching co ~ (co2 |> co3) -- and I have no idea what to do there -- or even if it can occur -- Failing seems the simplest thing to do; it's certainly safe. @@ -1114,23 +1115,23 @@ match renv subst (Coercion co1) (Coercion co2) MRefl -- Note [Cancel reflexive casts] match renv subst e1 (Cast e2 co2) mco - = match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoR (castCoToCo (exprType e2) co2) mco)) + = match renv subst e1 e2 (checkReflexiveCastCo (exprType e2) (mkTransCastCo co2 mco)) -- checkReflexiveMCo: cancel casts if possible -- This is important: see Note [Cancel reflexive casts] match renv subst (Cast e1 co1) e2 mco - = matchTemplateCast renv subst e1 (castCoToCo (exprType e1) co1) e2 mco + = matchTemplateCast renv subst e1 co1 e2 mco ------------------------ Literals --------------------- match _ subst (Lit lit1) (Lit lit2) mco | lit1 == lit2 - = assertPpr (isReflMCo mco) (ppr mco) $ + = assertPpr (isReflCastCo mco) (ppr mco) $ Just subst ------------------------ Variables --------------------- -- The Var case follows closely what happens in GHC.Core.Unify.match match renv subst (Var v1) e2 mco - = match_var renv subst v1 (mkCastMCo e2 mco) + = match_var renv subst v1 (mkCastCo e2 mco) match renv subst e1 (Var v2) mco -- Note [Expanding variables] | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] @@ -1148,7 +1149,7 @@ match renv subst e1 (Var v2) mco -- Note [Expanding variables] -- See Note [Matching higher order patterns] match renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env }) subst e1@App{} e2 - MRefl -- Like the App case we insist on Refl here + ReflCastCo -- Like the App case we insist on Refl here -- See Note [Casts in the target] | (Var f, args) <- collectArgs e1 , let f' = rnOccL rn_env f -- See similar rnOccL in match_var @@ -1308,9 +1309,9 @@ Two wrinkles: -- (e1 e2) ~ (d1 d2) |> co -- See Note [Cancel reflexive casts]: in the Cast equations for 'match' -- we aggressively ensure that if MCo is reflective, it really is MRefl. -match renv subst (App f1 a1) (App f2 a2) MRefl - = do { subst' <- match renv subst f1 f2 MRefl - ; match renv subst' a1 a2 MRefl } +match renv subst (App f1 a1) (App f2 a2) ReflCastCo + = do { subst' <- match renv subst f1 f2 ReflCastCo + ; match renv subst' a1 a2 ReflCastCo } ------------------------ Float lets --------------------- match renv subst e1 (Let bind e2) mco @@ -1336,7 +1337,7 @@ match renv subst e1 (Let bind e2) mco ------------------------ Lambdas --------------------- match renv subst (Lam x1 e1) e2 mco - | let casted_e2 = mkCastMCo e2 mco + | let casted_e2 = mkCastCo e2 mco in_scope = extendInScopeSetSet (rnInScopeSet (rv_lcl renv)) (exprFreeVars casted_e2) in_scope_env = ISE in_scope (rv_unf renv) @@ -1349,7 +1350,7 @@ match renv subst (Lam x1 e1) e2 mco -- See Note [Lambdas in the template] = let renv' = rnMatchBndr2 renv x1 x2 subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } - in match renv' subst' e1 e2' MRefl + in match renv' subst' e1 e2' ReflCastCo match renv subst e1 e2@(Lam {}) mco | Just (renv', e2') <- eta_reduce renv e2 -- See Note [Eta reduction in the target] @@ -1400,7 +1401,7 @@ match renv (tv_subst, id_subst, binds) e1 match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) mco = do { subst1 <- match_ty renv subst ty1 ty2 - ; subst2 <- match renv subst1 e1 e2 MRefl + ; subst2 <- match renv subst1 e1 e2 ReflCastCo ; let renv' = rnMatchBndr2 renv x1 x2 ; match_alts renv' subst2 alts1 alts2 mco -- Alts are both sorted } @@ -1503,29 +1504,29 @@ Hence ------------- matchTemplateCast :: RuleMatchEnv -> RuleSubst - -> CoreExpr -> Coercion - -> CoreExpr -> MCoercion + -> CoreExpr -> CastCoercion + -> CoreExpr -> CastCoercion -> Maybe RuleSubst matchTemplateCast renv subst e1 co1 e2 mco | isEmptyVarSet $ fvVarSet $ filterFV (`elemVarSet` rv_tmpls renv) $ -- Check that the coercion does not - tyCoFVsOfCo substed_co -- mention any of the template variables + tyCoFVsOfCastCoercion substed_co -- mention any of the template variables = -- This is the good path -- See Note [Casts in the template] wrinkle (CT0) - match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoL mco (mkSymCo substed_co))) + match renv subst e1 e2 (checkReflexiveCastCo substed_ty (mkTransCastCo mco (mkSymCastCo substed_ty substed_co))) + -- AMG TODO: should be able to make checkReflexiveCastCo cheaper here? | otherwise = -- This is the Deeply Suspicious Path -- See Note [Casts in the template] - do { let co2 = case mco of - MRefl -> mkRepReflCo (exprType e2) - MCo co2 -> co2 + do { let co2 = mco ; subst1 <- match_co renv subst co1 co2 -- If match_co succeeds, then (exprType e1) = (exprType e2) - -- Hence the MRefl in the next line - ; match renv subst1 e1 e2 MRefl } + -- Hence the ReflCastCo in the next line + ; match renv subst1 e1 e2 ReflCastCo } where - substed_co = substCo current_subst co1 + substed_ty = substTy current_subst (exprType e1) + substed_co = substCastCo current_subst co1 current_subst :: Subst current_subst = mkTCvSubst (rnInScopeSet (rv_lcl renv)) @@ -1538,8 +1539,8 @@ matchTemplateCast renv subst e1 co1 e2 mco match_co :: RuleMatchEnv -> RuleSubst - -> Coercion - -> Coercion + -> CastCoercion + -> CastCoercion -> Maybe RuleSubst -- We only match if the template is a coercion variable or Refl: -- see Note [Casts in the template] @@ -1548,7 +1549,7 @@ match_co :: RuleMatchEnv -- But if match_co succeeds, it /is/ guaranteed that -- coercionKind (subst template) = coercionKind target -match_co renv subst co1 co2 +match_co renv subst (CCoercion co1) (CCoercion co2) | Just cv <- getCoVar_maybe co1 = match_var renv subst cv (Coercion co2) @@ -1563,6 +1564,7 @@ match_co renv subst co1 co2 | otherwise = Nothing +match_co _renv _subst _ _ = Nothing -- TODO: support non-CCoercions in rule matcher ------------- rnMatchBndr2 :: RuleMatchEnv -> Var -> Var -> RuleMatchEnv @@ -1575,7 +1577,7 @@ rnMatchBndr2 renv x1 x2 match_alts :: RuleMatchEnv -> RuleSubst -> [CoreAlt] -- Template - -> [CoreAlt] -> MCoercion -- Target + -> [CoreAlt] -> CastCoercion -- Target -> Maybe RuleSubst match_alts _ subst [] [] _ = return subst @@ -2018,7 +2020,7 @@ ruleAppCheck_help env fn args rules mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, not (isJust (match_fn rule_arg arg))] - match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl + match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg ReflCastCo where renv = RV { rv_lcl = mkRnEnv2 in_scope , rv_tmpls = mkVarSet rule_bndrs ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -31,8 +31,8 @@ import GHC.Core.Unfold.Make import GHC.Core.Make ( FloatBind(..), mkWildValBinder ) import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) import GHC.Core.DataCon -import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) ) -import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList +import GHC.Core.Coercion.Opt ( optCoercion, optCastCoercion, OptCoercionOpts (..) ) +import GHC.Core.Type hiding ( extendTvSubst, extendCvSubst, extendTvSubstList , isInScope, substTyVarBndr, cloneTyVarBndr ) import GHC.Core.Predicate( isCoVarType ) import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) @@ -213,7 +213,7 @@ simpleOptPgm opts this_mod binds rules = ---------------------- type SimpleClo = (SimpleOptEnv, InExpr) -data SimpleContItem = ApplyToArg SimpleClo | CastIt OutCoercion +data SimpleContItem = ApplyToArg SimpleClo | CastIt OutCastCoercion instance Outputable SimpleContItem where ppr (ApplyToArg (_, arg)) = text "ARG" <+> ppr arg @@ -402,7 +402,7 @@ simple_app env e0@(Lam {}) as0@(_:_) = rebuild_app env (simple_opt_expr env e) as do_beta env (Cast e co) as = - do_beta env e (add_cast env (castCoToCo (exprType e) co) as) -- TODO eliminate castCoToCo? + do_beta env e (add_cast env (exprType e) co as) do_beta env body as = simple_app env body as @@ -450,21 +450,21 @@ simple_app env (Let bind body) args expr' = Let bind' (simple_opt_expr env' body) simple_app env (Cast e co) as - = simple_app env e (add_cast env (castCoToCo (exprType e) co) as) -- TODO eliminate castCoToCo? + = simple_app env e (add_cast env (exprType e) co as) simple_app env e as = rebuild_app env (simple_opt_expr env e) as -add_cast :: SimpleOptEnv -> InCoercion -> [SimpleContItem] -> [SimpleContItem] -add_cast env co1 as - | isReflCo co1' +add_cast :: SimpleOptEnv -> InType -> InCastCoercion -> [SimpleContItem] -> [SimpleContItem] +add_cast env tyL co1 as + | isReflCastCo co1' = as | otherwise = case as of - CastIt co2:rest -> CastIt (co1' `mkTransCo` co2):rest + CastIt co2:rest -> CastIt (co1' `mkTransCastCo` co2):rest _ -> CastIt co1':as where - co1' = optCoercion (so_co_opts (soe_opts env)) (soe_subst env) co1 + co1' = optCastCoercion (so_co_opts (soe_opts env)) (soe_subst env) tyL co1 rebuild_app :: HasDebugCallStack => SimpleOptEnv -> OutExpr -> [SimpleContItem] -> OutExpr @@ -473,7 +473,7 @@ rebuild_app env fun args = foldl mk_app fun args in_scope = soeInScope env mk_app out_fun = \case ApplyToArg arg -> App out_fun (simple_opt_clo in_scope arg) - CastIt co -> mk_cast out_fun (CCoercion co) + CastIt co -> mk_cast out_fun co {- Note [Desugaring unlifted newtypes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1340,7 +1340,7 @@ data-con wrappers, and that cure would be worse than the disease. This Note exists solely to document the problem. -} -data ConCont = CC [CoreExpr] MCoercion +data ConCont = CC [CoreExpr] CastCoercion -- Substitution already applied -- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument @@ -1362,7 +1362,7 @@ exprIsConApp_maybe :: HasDebugCallStack => InScopeEnv -> CoreExpr -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) exprIsConApp_maybe ise@(ISE in_scope id_unf) expr - = go (Left in_scope) [] expr (CC [] MRefl) + = go (Left in_scope) [] expr (CC [] ReflCastCo) where go :: Either InScopeSet Subst -- Left in-scope means "empty substitution" @@ -1375,10 +1375,10 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr go subst floats (Tick t expr) cont | not (tickishIsCode t) = go subst floats expr cont - go subst floats (Cast expr co1) (CC args m_co2) - | Just (args', m_co1') <- pushCoArgs (subst_co subst (castCoToCo (exprType expr) co1)) args + go subst floats (Cast expr co1) (CC args m_co2) -- TODO: is the subst_ty below needed? + | Just (args', m_co1') <- pushCoArgs (subst_ty subst (exprType expr)) (subst_cast_co subst co1) args -- See Note [Push coercions in exprIsConApp_maybe] - = go subst floats expr (CC args' (m_co1' `mkTransMCo` m_co2)) + = go subst floats expr (CC args' (m_co1' `mkTransCastCo` m_co2)) go subst floats (App fun arg) (CC args mco) | let arg_type = exprType arg @@ -1512,8 +1512,11 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr subst_extend_in_scope (Left in_scope) v = Left (in_scope `extendInScopeSet` v) subst_extend_in_scope (Right s) v = Right (s `extendSubstInScope` v) - subst_co (Left {}) co = co - subst_co (Right s) co = GHC.Core.Subst.substCo s co + subst_cast_co (Left {}) co = co + subst_cast_co (Right s) co = substCastCo s co + + subst_ty (Left {}) ty = ty + subst_ty (Right s) ty = substTy s ty subst_expr (Left {}) e = e subst_expr (Right s) e = substExpr s e @@ -1565,7 +1568,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr (right, _, _) -> pprPanic "case_bind did not preserve Left" (ppr in_scope $$ ppr arg $$ ppr right) -- See Note [exprIsConApp_maybe on literal strings] -dealWithStringLiteral :: Var -> BS.ByteString -> MCoercion +dealWithStringLiteral :: Var -> BS.ByteString -> CastCoercion -> Maybe (DataCon, [Type], [CoreExpr]) -- This is not possible with user-supplied empty literals, GHC.Core.Make.mkStringExprFS @@ -1666,13 +1669,12 @@ exprIsLambda_maybe ise (Tick t e) = Just (x, e, t:ts) -- Also possible: A casted lambda. Push the coercion inside -exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e cco) +exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co) | Just (x, e,ts) <- exprIsLambda_maybe ise casted_e -- Only do value lambdas. -- this implies that x is not in scope in gamma (makes this code simpler) , not (isTyVar x) && not (isCoVar x) - , let co = castCoToCo (exprType casted_e) cco - , assert (not $ x `elemVarSet` tyCoVarsOfCo co) True + , assert (not $ x `elemVarSet` tyCoVarsOfCastCo co) True , Just (x',e') <- pushCoercionIntoLambda (mkEmptySubst in_scope_set) x e co , let res = Just (x',e',ts) = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) ===================================== compiler/GHC/Core/TyCo/FVs.hs ===================================== @@ -21,7 +21,7 @@ module GHC.Core.TyCo.FVs shallowCoVarsOfCo, shallowCoVarsOfCos, shallowCoVarsOfCastCo, tyCoVarsOfCastCoercionDSet, tyCoVarsOfCoDSet, - tyCoFVsOfCo, tyCoFVsOfCos, tyCoFVsOfCoVarSet, + tyCoFVsOfCo, tyCoFVsOfCos, tyCoFVsOfCoVarSet, tyCoFVsOfCastCoercion, tyCoVarsOfCoList, coVarsOfCoDSet, coVarsOfCosDSet, ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -22,7 +22,7 @@ module GHC.Core.Utils ( -- * Properties of expressions exprType, coreAltType, coreAltsType, - mkLamType, mkLamTypes, + mkLamType, mkLamTypes, mkPiMCos, mkFunctionType, exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe, trivial_expr_fold, @@ -188,6 +188,12 @@ mkLamType v body_ty mkLamTypes vs ty = foldr mkLamType ty vs +mkPiMCos :: [Var] -> CastCoercion -> CastCoercion +mkPiMCos _ ReflCastCo = ReflCastCo +mkPiMCos vs (CCoercion co) = CCoercion (mkPiCos Representational vs co) +mkPiMCos vs (ZCoercion ty cos) = ZCoercion (mkLamTypes vs ty) cos + + {- Note [Type bindings] ~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/58a31cb920f13c461490cdad5f6302… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/58a31cb920f13c461490cdad5f6302… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ubsan] 6 commits: hadrian: add support for building with UndefinedBehaviorSanitizer
by Cheng Shao (＠TerrorJack) 25 Nov '25

25 Nov '25

Cheng Shao pushed to branch wip/ubsan at Glasgow Haskell Compiler / GHC Commits: 1047a8a2 by Cheng Shao at 2025-11-25T12:43:59+01:00 hadrian: add support for building with UndefinedBehaviorSanitizer This patch adds a +ubsan flavour transformer to hadrian to build all stage1+ C/C++ code with UndefinedBehaviorSanitizer. This is particularly useful to catch potential undefined behavior in the RTS codebase. - - - - - e0c517b2 by Cheng Shao at 2025-11-25T12:44:04+01:00 configure: bump LlvmMaxVersion to 22 This commit bumps LlvmMaxVersion to 22; 21.x releases have been available since Aug 26th, 2025 and there's no regressions with 21.x so far. This bump is also required for updating fedora image to 43. - - - - - d5fd2758 by Cheng Shao at 2025-11-25T12:44:04+01:00 ci: add x86_64-linux-fedora43-validate+debug_info+ubsan job This patch updates fedora image to 43, and adds a `x86_64-linux-fedora43-validate+debug_info+ubsan` job that's run in validate/nightly pipelines to catch undefined behavior in the RTS codebase. - - - - - 9b82355c by Cheng Shao at 2025-11-25T12:44:35+01:00 rts: fix zero-length VLA undefined behavior in interpretBCO This commit fixes a zero-length VLA undefined behavior in interpretBCO, caught by UBSan: ``` +rts/Interpreter.c:3133:19: runtime variable length array bound evaluates to non-positive value 0 ``` - - - - - 127800a2 by Cheng Shao at 2025-11-25T12:44:35+01:00 rts: fix unaligned ReadSpB in interpretBCO This commit fixes unaligned ReadSpB in interpretBCO, caught by UBSan: ``` +rts/Interpreter.c:2174:64: runtime load of misaligned address 0x004202059dd1 for type 'StgWord', which requires 8 byte alignment ``` To perform proper unaligned read, we define StgUnalignedWord as a type alias of StgWord with aligned(1) attribute, and load StgUnalignedWord instead of StgWord in ReadSpB, so the C compiler is aware that we're not loading with natural alignment. - - - - - f958e99b by Cheng Shao at 2025-11-25T12:44:35+01:00 rts: fix signed integer overflow in subword arithmetic in interpretBCO - - - - - 14 changed files: - .gitlab-ci.yml - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - configure.ac - hadrian/doc/flavours.md - hadrian/src/Flavour.hs - + rts/.ubsan-suppressions - rts/Interpreter.c - rts/include/stg/Types.h - rts/rts.cabal - testsuite/driver/testglobals.py - testsuite/driver/testlib.py Changes: ===================================== .gitlab-ci.yml ===================================== @@ -11,7 +11,7 @@ variables: GIT_SSL_NO_VERIFY: "1" # Commit of ghc/ci-images repository from which to pull Docker images - DOCKER_REV: a97d5c67d803c6b3811c6cccdf33dc8e9d7eafe3 + DOCKER_REV: 91427f8ccea7dd472d6e0e44db858b4003aef826 # Sequential version number of all cached things. # Bump to invalidate GitLab CI cache. @@ -444,14 +444,14 @@ hadrian-ghc-in-ghci: hadrian-multi: stage: testing needs: - - job: x86_64-linux-fedora42-release + - job: x86_64-linux-fedora43-release optional: true - - job: nightly-x86_64-linux-fedora42-release + - job: nightly-x86_64-linux-fedora43-release optional: true - - job: release-x86_64-linux-fedora42-release + - job: release-x86_64-linux-fedora43-release optional: true dependencies: null - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV" before_script: # workaround for docker permissions - sudo chown ghc:ghc -R . @@ -471,7 +471,7 @@ hadrian-multi: - ls - | mkdir tmp - tar -xf ghc-x86_64-linux-fedora42-release.tar.xz -C tmp + tar -xf ghc-x86_64-linux-fedora43-release.tar.xz -C tmp pushd tmp/ghc-*/ ./configure --prefix=$root make install @@ -533,17 +533,17 @@ test-cabal-reinstall-x86_64-linux-deb10: abi-test-nightly: stage: full-build needs: - - job: nightly-x86_64-linux-fedora42-release-hackage - - job: nightly-x86_64-linux-fedora42-release + - job: nightly-x86_64-linux-fedora43-release-hackage + - job: nightly-x86_64-linux-fedora43-release tags: - x86_64-linux - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV" dependencies: null before_script: - mkdir -p normal - mkdir -p hackage - - tar -xf ghc-x86_64-linux-fedora42-release.tar.xz -C normal/ - - tar -xf ghc-x86_64-linux-fedora42-release-hackage_docs.tar.xz -C hackage/ + - tar -xf ghc-x86_64-linux-fedora43-release.tar.xz -C normal/ + - tar -xf ghc-x86_64-linux-fedora43-release-hackage_docs.tar.xz -C hackage/ script: - .gitlab/ci.sh compare_interfaces_of "normal/ghc-*" "hackage/ghc-*" artifacts: @@ -620,9 +620,9 @@ doc-tarball: hackage-doc-tarball: stage: packaging needs: - - job: nightly-x86_64-linux-fedora42-release-hackage + - job: nightly-x86_64-linux-fedora43-release-hackage optional: true - - job: release-x86_64-linux-fedora42-release-hackage + - job: release-x86_64-linux-fedora43-release-hackage optional: true - job: source-tarball tags: @@ -639,7 +639,7 @@ hackage-doc-tarball: - hackage_docs before_script: - tar -xf ghc-*[0-9]-src.tar.xz - - tar -xf ghc-x86_64-linux-fedora42-release.tar.xz -C ghc*/ + - tar -xf ghc-x86_64-linux-fedora43-release.tar.xz -C ghc*/ script: - cd ghc*/ - mv .gitlab/rel_eng/upload_ghc_libs.py . @@ -765,7 +765,7 @@ test-bootstrap: # Triggering jobs in the ghc/head.hackage project requires that we have a job # token for that repository. Furthermore the head.hackage CI job must have # access to an unprivileged access token with the ability to query the ghc/ghc -# project such that it can find the job ID of the fedora42 job for the current +# project such that it can find the job ID of the fedora43 job for the current # pipeline. # # hackage-lint: Can be triggered on any MR, normal validate pipeline or nightly build. @@ -852,7 +852,7 @@ nightly-hackage-lint: nightly-hackage-perf: needs: - - job: nightly-x86_64-linux-fedora42-release + - job: nightly-x86_64-linux-fedora43-release optional: true artifacts: false - job: nightly-aarch64-linux-deb12-validate @@ -871,7 +871,7 @@ nightly-hackage-perf: release-hackage-lint: needs: - - job: release-x86_64-linux-fedora42-release + - job: release-x86_64-linux-fedora43-release optional: true artifacts: false - job: release-aarch64-linux-deb12-release+no_split_sections @@ -957,13 +957,13 @@ perf-nofib: allow_failure: true stage: testing needs: - - job: x86_64-linux-fedora42-release + - job: x86_64-linux-fedora43-release optional: true - - job: nightly-x86_64-linux-fedora42-release + - job: nightly-x86_64-linux-fedora43-release optional: true - - job: release-x86_64-linux-fedora42-release + - job: release-x86_64-linux-fedora43-release optional: true - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV" rules: - when: never - *full-ci @@ -976,7 +976,7 @@ perf-nofib: - root=$(pwd)/ghc - | mkdir tmp - tar -xf ../ghc-x86_64-linux-fedora42-release.tar.xz -C tmp + tar -xf ../ghc-x86_64-linux-fedora43-release.tar.xz -C tmp pushd tmp/ghc-*/ ./configure --prefix=$root make install @@ -1000,14 +1000,14 @@ perf-nofib: perf: stage: testing needs: - - job: x86_64-linux-fedora42-release + - job: x86_64-linux-fedora43-release optional: true - - job: nightly-x86_64-linux-fedora42-release + - job: nightly-x86_64-linux-fedora43-release optional: true - - job: release-x86_64-linux-fedora42-release + - job: release-x86_64-linux-fedora43-release optional: true dependencies: null - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV" tags: - x86_64-linux-perf before_script: @@ -1017,7 +1017,7 @@ perf: - root=$(pwd)/ghc - | mkdir tmp - tar -xf ghc-x86_64-linux-fedora42-release.tar.xz -C tmp + tar -xf ghc-x86_64-linux-fedora43-release.tar.xz -C tmp pushd tmp/ghc-*/ ./configure --prefix=$root make install @@ -1041,14 +1041,14 @@ perf: abi-test: stage: testing needs: - - job: x86_64-linux-fedora42-release + - job: x86_64-linux-fedora43-release optional: true - - job: nightly-x86_64-linux-fedora42-release + - job: nightly-x86_64-linux-fedora43-release optional: true - - job: release-x86_64-linux-fedora42-release + - job: release-x86_64-linux-fedora43-release optional: true dependencies: null - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV" rules: - if: $CI_MERGE_REQUEST_ID - if: '$CI_COMMIT_BRANCH == "master"' @@ -1059,7 +1059,7 @@ abi-test: - root=$(pwd)/ghc - | mkdir tmp - tar -xf ghc-x86_64-linux-fedora42-release.tar.xz -C tmp + tar -xf ghc-x86_64-linux-fedora43-release.tar.xz -C tmp pushd tmp/ghc-*/ ./configure --prefix=$root make install @@ -1214,7 +1214,7 @@ ghcup-metadata-nightly: extends: .ghcup-metadata # Explicit needs for validate pipeline because we only need certain bindists needs: - - job: nightly-x86_64-linux-fedora42-release + - job: nightly-x86_64-linux-fedora43-release artifacts: false - job: nightly-x86_64-linux-ubuntu24_04-validate artifacts: false @@ -1265,7 +1265,7 @@ ghcup-metadata-nightly: # Update the ghcup metadata with information about this nightly pipeline ghcup-metadata-nightly-push: stage: deploy - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV" dependencies: null tags: - x86_64-linux ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -82,7 +82,7 @@ The generated names for the jobs is important as there are a few downstream cons of the jobs artifacts. Therefore some care should be taken if changing the generated names of jobs to update these other places. -1. fedora42 jobs are required by head.hackage +1. fedora43 jobs are required by head.hackage 2. The fetch-gitlab release utility pulls release artifacts from the 3. The ghc-head-from script downloads release artifacts based on a pipeline change. 4. Some subsequent CI jobs have explicit dependencies (for example docs-tarball, perf, perf-nofib) @@ -118,7 +118,7 @@ data LinuxDistro | Debian11Js | Debian10 | Debian9 - | Fedora42 + | Fedora43 | Ubuntu2404LoongArch64 | Ubuntu2404 | Ubuntu2204 @@ -161,6 +161,7 @@ data BuildConfig , hostFullyStatic :: Bool , tablesNextToCode :: Bool , threadSanitiser :: Bool + , ubsan :: Bool , noSplitSections :: Bool , validateNonmovingGc :: Bool , textWithSIMDUTF :: Bool @@ -186,6 +187,7 @@ mkJobFlavour BuildConfig{..} = Flavour buildFlavour opts [FullyStatic | fullyStatic] ++ [HostFullyStatic | hostFullyStatic] ++ [ThreadSanitiser | threadSanitiser] ++ + [UBSan | ubsan] ++ [NoSplitSections | noSplitSections, buildFlavour == Release ] ++ [BootNonmovingGc | validateNonmovingGc ] ++ [TextWithSIMDUTF | textWithSIMDUTF] @@ -198,6 +200,7 @@ data FlavourTrans = | FullyStatic | HostFullyStatic | ThreadSanitiser + | UBSan | NoSplitSections | BootNonmovingGc | TextWithSIMDUTF @@ -226,6 +229,7 @@ vanilla = BuildConfig , hostFullyStatic = False , tablesNextToCode = True , threadSanitiser = False + , ubsan = False , noSplitSections = False , validateNonmovingGc = False , textWithSIMDUTF = False @@ -279,6 +283,9 @@ llvm = vanilla { llvmBootstrap = True } tsan :: BuildConfig tsan = vanilla { threadSanitiser = True } +enableUBSan :: BuildConfig +enableUBSan = vanilla { withDwarf = True, ubsan = True } + noTntc :: BuildConfig noTntc = vanilla { tablesNextToCode = False } @@ -318,7 +325,7 @@ distroName Debian12Riscv = "deb12-riscv" distroName Debian12Wine = "deb12-wine" distroName Debian10 = "deb10" distroName Debian9 = "deb9" -distroName Fedora42 = "fedora42" +distroName Fedora43 = "fedora43" distroName Ubuntu2404LoongArch64 = "ubuntu24_04-loongarch" distroName Ubuntu1804 = "ubuntu18_04" distroName Ubuntu2004 = "ubuntu20_04" @@ -373,6 +380,7 @@ flavourString (Flavour base trans) = base_string base ++ concatMap (("+" ++) . f flavour_string FullyStatic = "fully_static" flavour_string HostFullyStatic = "host_fully_static" flavour_string ThreadSanitiser = "thread_sanitizer_cmm" + flavour_string UBSan = "ubsan" flavour_string NoSplitSections = "no_split_sections" flavour_string BootNonmovingGc = "boot_nonmoving_gc" flavour_string TextWithSIMDUTF = "text_simdutf" @@ -1196,13 +1204,22 @@ rhel_x86 = fedora_x86 :: [JobGroup Job] fedora_x86 = - [ -- Fedora42 job is always built with perf so there's one job in the normal + [ -- Fedora43 job is always built with perf so there's one job in the normal -- validate pipeline which is built with perf. - fastCI (standardBuildsWithConfig Amd64 (Linux Fedora42) releaseConfig) + fastCI (standardBuildsWithConfig Amd64 (Linux Fedora43) releaseConfig) -- This job is only for generating head.hackage docs - , hackage_doc_job (disableValidate (standardBuildsWithConfig Amd64 (Linux Fedora42) releaseConfig)) - , disableValidate (standardBuildsWithConfig Amd64 (Linux Fedora42) dwarf) - , disableValidate (standardBuilds Amd64 (Linux Fedora42)) + , hackage_doc_job (disableValidate (standardBuildsWithConfig Amd64 (Linux Fedora43) releaseConfig)) + , disableValidate (standardBuildsWithConfig Amd64 (Linux Fedora43) dwarf) + , disableValidate (standardBuilds Amd64 (Linux Fedora43)) + -- For UBSan jobs, only enable for validate/nightly pipelines. + -- Also disable docs since it's not the point for UBSan jobs. + , modifyJobs + ( setVariable "HADRIAN_ARGS" "--docs=none" + . addVariable + "UBSAN_OPTIONS" + "suppressions=$CI_PROJECT_DIR/rts/.ubsan-suppressions" + ) + $ validateBuilds Amd64 (Linux Fedora43) enableUBSan ] where hackage_doc_job = rename (<> "-hackage") . modifyJobs (addVariable "HADRIAN_ARGS" "--haddock-for-hackage") @@ -1364,7 +1381,7 @@ platform_mapping = Map.map go combined_result , "x86_64-linux-deb11-validate" , "x86_64-linux-deb12-validate" , "x86_64-linux-deb10-validate+debug_info" - , "x86_64-linux-fedora42-release" + , "x86_64-linux-fedora43-release" , "x86_64-linux-deb11-cross_aarch64-linux-gnu-validate" , "x86_64-windows-validate" , "aarch64-linux-deb12-validate" @@ -1379,13 +1396,13 @@ platform_mapping = Map.map go combined_result , "nightly-aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate" , "nightly-x86_64-linux-alpine3_12-validate+fully_static" , "nightly-x86_64-linux-deb10-validate" - , "nightly-x86_64-linux-fedora42-release" + , "nightly-x86_64-linux-fedora43-release" , "nightly-x86_64-windows-validate" , "release-x86_64-linux-alpine3_12-release+fully_static+no_split_sections" , "release-x86_64-linux-deb10-release" , "release-x86_64-linux-deb11-release" , "release-x86_64-linux-deb12-release" - , "release-x86_64-linux-fedora42-release" + , "release-x86_64-linux-fedora43-release" , "release-x86_64-windows-release" ] ===================================== .gitlab/jobs.yaml ===================================== @@ -2942,7 +2942,7 @@ "XZ_OPT": "-9" } }, - "nightly-x86_64-linux-fedora42-release": { + "nightly-x86_64-linux-fedora43-release": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -2953,7 +2953,7 @@ "artifacts": { "expire_in": "8 weeks", "paths": [ - "ghc-x86_64-linux-fedora42-release.tar.xz", + "ghc-x86_64-linux-fedora43-release.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -2963,14 +2963,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora42-$CACHE_REV", + "key": "x86_64-linux-fedora43-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -2996,16 +2996,16 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-release", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora43-release", "BUILD_FLAVOUR": "release", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora42-release", + "TEST_ENV": "x86_64-linux-fedora43-release", "XZ_OPT": "-9" } }, - "nightly-x86_64-linux-fedora42-release-hackage": { + "nightly-x86_64-linux-fedora43-release-hackage": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -3016,7 +3016,7 @@ "artifacts": { "expire_in": "8 weeks", "paths": [ - "ghc-x86_64-linux-fedora42-release.tar.xz", + "ghc-x86_64-linux-fedora43-release.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -3026,14 +3026,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora42-$CACHE_REV", + "key": "x86_64-linux-fedora43-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -3059,17 +3059,17 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-release", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora43-release", "BUILD_FLAVOUR": "release", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "HADRIAN_ARGS": "--haddock-for-hackage", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora42-release", + "TEST_ENV": "x86_64-linux-fedora43-release", "XZ_OPT": "-9" } }, - "nightly-x86_64-linux-fedora42-validate": { + "nightly-x86_64-linux-fedora43-validate": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -3080,7 +3080,7 @@ "artifacts": { "expire_in": "8 weeks", "paths": [ - "ghc-x86_64-linux-fedora42-validate.tar.xz", + "ghc-x86_64-linux-fedora43-validate.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -3090,14 +3090,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora42-$CACHE_REV", + "key": "x86_64-linux-fedora43-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -3123,16 +3123,16 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-validate", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora43-validate", "BUILD_FLAVOUR": "validate", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora42-validate", + "TEST_ENV": "x86_64-linux-fedora43-validate", "XZ_OPT": "-9" } }, - "nightly-x86_64-linux-fedora42-validate+debug_info": { + "nightly-x86_64-linux-fedora43-validate+debug_info": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -3143,7 +3143,7 @@ "artifacts": { "expire_in": "8 weeks", "paths": [ - "ghc-x86_64-linux-fedora42-validate+debug_info.tar.xz", + "ghc-x86_64-linux-fedora43-validate+debug_info.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -3153,14 +3153,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora42-$CACHE_REV", + "key": "x86_64-linux-fedora43-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -3186,12 +3186,77 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-validate+debug_info", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora43-validate+debug_info", "BUILD_FLAVOUR": "validate+debug_info", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora42-validate+debug_info", + "TEST_ENV": "x86_64-linux-fedora43-validate+debug_info", + "XZ_OPT": "-9" + } + }, + "nightly-x86_64-linux-fedora43-validate+debug_info+ubsan": { + "after_script": [ + ".gitlab/ci.sh save_cache", + ".gitlab/ci.sh save_test_output", + ".gitlab/ci.sh clean", + "cat ci_timings.txt" + ], + "allow_failure": false, + "artifacts": { + "expire_in": "8 weeks", + "paths": [ + "ghc-x86_64-linux-fedora43-validate+debug_info+ubsan.tar.xz", + "junit.xml", + "unexpected-test-output.tar.gz" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "x86_64-linux-fedora43-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [], + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + } + ], + "rules": [ + { + "if": "(\"true\" == \"true\") && ($RELEASE_JOB != \"yes\") && ($NIGHTLY)", + "when": "on_success" + } + ], + "script": [ + "sudo chown ghc:ghc -R .", + ".gitlab/ci.sh setup", + ".gitlab/ci.sh configure", + ".gitlab/ci.sh build_hadrian", + ".gitlab/ci.sh test_hadrian" + ], + "stage": "full-build", + "tags": [ + "x86_64-linux" + ], + "variables": { + "BIGNUM_BACKEND": "gmp", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora43-validate+debug_info+ubsan", + "BUILD_FLAVOUR": "validate+debug_info+ubsan", + "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", + "HADRIAN_ARGS": "--docs=none", + "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", + "RUNTEST_ARGS": "", + "TEST_ENV": "x86_64-linux-fedora43-validate+debug_info+ubsan", + "UBSAN_OPTIONS": "suppressions=$CI_PROJECT_DIR/rts/.ubsan-suppressions", "XZ_OPT": "-9" } }, @@ -4808,7 +4873,7 @@ "XZ_OPT": "-9" } }, - "release-x86_64-linux-fedora42-release": { + "release-x86_64-linux-fedora43-release": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -4819,7 +4884,7 @@ "artifacts": { "expire_in": "1 year", "paths": [ - "ghc-x86_64-linux-fedora42-release.tar.xz", + "ghc-x86_64-linux-fedora43-release.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -4829,14 +4894,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora42-$CACHE_REV", + "key": "x86_64-linux-fedora43-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -4862,17 +4927,17 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-release", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora43-release", "BUILD_FLAVOUR": "release", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "IGNORE_PERF_FAILURES": "all", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora42-release", + "TEST_ENV": "x86_64-linux-fedora43-release", "XZ_OPT": "-9" } }, - "release-x86_64-linux-fedora42-release+debug_info": { + "release-x86_64-linux-fedora43-release+debug_info": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -4883,7 +4948,7 @@ "artifacts": { "expire_in": "1 year", "paths": [ - "ghc-x86_64-linux-fedora42-release+debug_info.tar.xz", + "ghc-x86_64-linux-fedora43-release+debug_info.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -4893,14 +4958,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora42-$CACHE_REV", + "key": "x86_64-linux-fedora43-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -4926,17 +4991,17 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-release+debug_info", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora43-release+debug_info", "BUILD_FLAVOUR": "release+debug_info", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "IGNORE_PERF_FAILURES": "all", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora42-release+debug_info", + "TEST_ENV": "x86_64-linux-fedora43-release+debug_info", "XZ_OPT": "-9" } }, - "release-x86_64-linux-fedora42-release-hackage": { + "release-x86_64-linux-fedora43-release-hackage": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -4947,7 +5012,7 @@ "artifacts": { "expire_in": "1 year", "paths": [ - "ghc-x86_64-linux-fedora42-release.tar.xz", + "ghc-x86_64-linux-fedora43-release.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -4957,14 +5022,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora42-$CACHE_REV", + "key": "x86_64-linux-fedora43-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -4990,14 +5055,14 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-release", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora43-release", "BUILD_FLAVOUR": "release", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "HADRIAN_ARGS": "--haddock-for-hackage", "IGNORE_PERF_FAILURES": "all", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora42-release", + "TEST_ENV": "x86_64-linux-fedora43-release", "XZ_OPT": "-9" } }, @@ -7032,7 +7097,7 @@ "TEST_ENV": "x86_64-linux-deb9-validate" } }, - "x86_64-linux-fedora42-release": { + "x86_64-linux-fedora43-release": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -7043,7 +7108,7 @@ "artifacts": { "expire_in": "2 weeks", "paths": [ - "ghc-x86_64-linux-fedora42-release.tar.xz", + "ghc-x86_64-linux-fedora43-release.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -7053,14 +7118,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora42-$CACHE_REV", + "key": "x86_64-linux-fedora43-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -7069,7 +7134,7 @@ ], "rules": [ { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora42-release(\\s|$).*/)) || (($ONLY_JOBS == null) && ((\"true\" == \"true\")))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora43-release(\\s|$).*/)) || (($ONLY_JOBS == null) && ((\"true\" == \"true\")))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", "when": "on_success" } ], @@ -7086,15 +7151,15 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-release", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora43-release", "BUILD_FLAVOUR": "release", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora42-release" + "TEST_ENV": "x86_64-linux-fedora43-release" } }, - "x86_64-linux-fedora42-release-hackage": { + "x86_64-linux-fedora43-release-hackage": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -7105,7 +7170,7 @@ "artifacts": { "expire_in": "2 weeks", "paths": [ - "ghc-x86_64-linux-fedora42-release.tar.xz", + "ghc-x86_64-linux-fedora43-release.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -7115,14 +7180,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora42-$CACHE_REV", + "key": "x86_64-linux-fedora43-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -7131,7 +7196,7 @@ ], "rules": [ { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora42-release(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora43-release(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", "when": "on_success" } ], @@ -7148,16 +7213,16 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-release", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora43-release", "BUILD_FLAVOUR": "release", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "HADRIAN_ARGS": "--haddock-for-hackage", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora42-release" + "TEST_ENV": "x86_64-linux-fedora43-release" } }, - "x86_64-linux-fedora42-validate": { + "x86_64-linux-fedora43-validate": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -7168,7 +7233,7 @@ "artifacts": { "expire_in": "2 weeks", "paths": [ - "ghc-x86_64-linux-fedora42-validate.tar.xz", + "ghc-x86_64-linux-fedora43-validate.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -7178,14 +7243,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora42-$CACHE_REV", + "key": "x86_64-linux-fedora43-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -7194,7 +7259,7 @@ ], "rules": [ { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora42-validate(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora43-validate(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", "when": "on_success" } ], @@ -7211,15 +7276,15 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-validate", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora43-validate", "BUILD_FLAVOUR": "validate", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora42-validate" + "TEST_ENV": "x86_64-linux-fedora43-validate" } }, - "x86_64-linux-fedora42-validate+debug_info": { + "x86_64-linux-fedora43-validate+debug_info": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -7230,7 +7295,7 @@ "artifacts": { "expire_in": "2 weeks", "paths": [ - "ghc-x86_64-linux-fedora42-validate+debug_info.tar.xz", + "ghc-x86_64-linux-fedora43-validate+debug_info.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -7240,14 +7305,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora42-$CACHE_REV", + "key": "x86_64-linux-fedora43-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -7256,7 +7321,7 @@ ], "rules": [ { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora42-validate\\+debug_info(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora43-validate\\+debug_info(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", "when": "on_success" } ], @@ -7273,12 +7338,76 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-validate+debug_info", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora43-validate+debug_info", "BUILD_FLAVOUR": "validate+debug_info", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora42-validate+debug_info" + "TEST_ENV": "x86_64-linux-fedora43-validate+debug_info" + } + }, + "x86_64-linux-fedora43-validate+debug_info+ubsan": { + "after_script": [ + ".gitlab/ci.sh save_cache", + ".gitlab/ci.sh save_test_output", + ".gitlab/ci.sh clean", + "cat ci_timings.txt" + ], + "allow_failure": false, + "artifacts": { + "expire_in": "2 weeks", + "paths": [ + "ghc-x86_64-linux-fedora43-validate+debug_info+ubsan.tar.xz", + "junit.xml", + "unexpected-test-output.tar.gz" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "x86_64-linux-fedora43-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [], + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora43:$DOCKER_REV", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + } + ], + "rules": [ + { + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora43-validate\\+debug_info\\+ubsan(\\s|$).*/)) || (($ONLY_JOBS == null) && ((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/))))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "when": "on_success" + } + ], + "script": [ + "sudo chown ghc:ghc -R .", + ".gitlab/ci.sh setup", + ".gitlab/ci.sh configure", + ".gitlab/ci.sh build_hadrian", + ".gitlab/ci.sh test_hadrian" + ], + "stage": "full-build", + "tags": [ + "x86_64-linux" + ], + "variables": { + "BIGNUM_BACKEND": "gmp", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora43-validate+debug_info+ubsan", + "BUILD_FLAVOUR": "validate+debug_info+ubsan", + "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", + "HADRIAN_ARGS": "--docs=none", + "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", + "RUNTEST_ARGS": "", + "TEST_ENV": "x86_64-linux-fedora43-validate+debug_info+ubsan", + "UBSAN_OPTIONS": "suppressions=$CI_PROJECT_DIR/rts/.ubsan-suppressions" } }, "x86_64-linux-rocky8-validate": { ===================================== .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py ===================================== @@ -23,8 +23,8 @@ def job_triple(job_name): 'release-x86_64-linux-ubuntu22_04-release': 'x86_64-ubuntu22_04-linux', 'release-x86_64-linux-ubuntu20_04-release': 'x86_64-ubuntu20_04-linux', 'release-x86_64-linux-ubuntu18_04-release': 'x86_64-ubuntu18_04-linux', - 'release-x86_64-linux-fedora42-release': 'x86_64-fedora42-linux', - 'release-x86_64-linux-fedora42-release+debug_info': 'x86_64-fedora42-linux-dwarf', + 'release-x86_64-linux-fedora43-release': 'x86_64-fedora43-linux', + 'release-x86_64-linux-fedora43-release+debug_info': 'x86_64-fedora43-linux-dwarf', 'release-x86_64-linux-deb12-release': 'x86_64-deb12-linux', 'release-x86_64-linux-deb11-release': 'x86_64-deb11-linux', 'release-x86_64-linux-deb10-release+debug_info': 'x86_64-deb10-linux-dwarf', ===================================== .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py ===================================== @@ -200,7 +200,7 @@ def mk_new_yaml(release_mode, version, date, pipeline_type, job_map): ubuntu2204 = mk(ubuntu("22_04")) ubuntu2404 = mk(ubuntu("24_04")) rocky8 = mk(rocky("8")) - fedora42 = mk(fedora(42)) + fedora43 = mk(fedora(43)) darwin_x86 = mk(darwin("x86_64")) darwin_arm64 = mk(darwin("aarch64")) windows = mk(windowsArtifact) @@ -239,7 +239,7 @@ def mk_new_yaml(release_mode, version, date, pipeline_type, job_map): , "unknown_versioning": ubuntu2004 } , "Linux_CentOS" : { "( >= 8 && < 9 )" : rocky8 , "unknown_versioning" : rocky8 } - , "Linux_Fedora" : { ">= 42": fedora42 + , "Linux_Fedora" : { ">= 43": fedora43 , "unknown_versioning": rocky8 } , "Linux_RedHat" : { "unknown_versioning": rocky8 } , "Linux_UnknownLinux" : { "unknown_versioning": rocky8 } ===================================== configure.ac ===================================== @@ -526,7 +526,7 @@ AC_SUBST(InstallNameToolCmd) # versions of LLVM simultaneously, but that stopped working around # 3.5/3.6 release of LLVM. LlvmMinVersion=13 # inclusive -LlvmMaxVersion=21 # not inclusive +LlvmMaxVersion=22 # not inclusive AC_SUBST([LlvmMinVersion]) AC_SUBST([LlvmMaxVersion]) ===================================== hadrian/doc/flavours.md ===================================== @@ -238,6 +238,10 @@ The supported transformers are listed below: <td><code>thread_sanitizer</code></td> <td>Build the runtime system with ThreadSanitizer support</td> </tr> + <tr> + <td><code>ubsan</code></td> + <td>Build all stage1+ C/C++ code with UndefinedBehaviorSanitizer support</td> + </tr> <tr> <td><code>llvm</code></td> <td>Use GHC's LLVM backend (`-fllvm`) for all stage1+ compilation.</td> ===================================== hadrian/src/Flavour.hs ===================================== @@ -7,6 +7,7 @@ module Flavour , addArgs , splitSections , enableThreadSanitizer + , enableUBSan , enableLateCCS , enableHashUnitIds , enableDebugInfo, enableTickyGhc @@ -33,6 +34,9 @@ import Data.Either import Data.Map (Map) import qualified Data.Map as M import qualified Data.Set as Set +import GHC.Platform.ArchOS +import Oracles.Flag +import Oracles.Setting import Packages import Flavour.Type import Settings.Parser @@ -53,6 +57,7 @@ flavourTransformers = M.fromList , "no_split_sections" =: noSplitSections , "thread_sanitizer" =: enableThreadSanitizer False , "thread_sanitizer_cmm" =: enableThreadSanitizer True + , "ubsan" =: enableUBSan , "llvm" =: viaLlvmBackend , "profiled_ghc" =: enableProfiledGhc , "no_dynamic_ghc" =: disableDynamicGhcPrograms @@ -258,6 +263,51 @@ enableThreadSanitizer instrumentCmm = addArgs $ notStage0 ? mconcat ] ] +-- | Whether or not -shared-libsan should be passed to clang at +-- link-time. +-- +-- See +-- https://github.com/llvm/llvm-project/blob/llvmorg-21.1.6/clang/lib/Driver/S…, +-- clang defaults to -shared-libsan on darwin/windows and +-- -static-libsan on linux. In general, -static-libsan is incredibly +-- problematic when multiple copies of the sanitizer runtimes coexist +-- in the same address space due to being linked into multiple Haskell +-- libraries. So we should explicitly specify `-shared-libsan` if +-- needed. +-- +-- A small downside of -shared-libsan is the clang-specific sanitizer +-- runtime shared library path needs to be manually specified via +-- @export LD_LIBRARY_PATH=$(dirname $(clang -print-libgcc-file-name +-- -rtlib=compiler-rt))@ for ld.so to find it at runtime. +needSharedLibSAN :: Action Bool +needSharedLibSAN = do + is_clang <- flag CcLlvmBackend + is_default_shared_libsan <- anyTargetOs [OSDarwin, OSMinGW32] + pure $ is_clang && not is_default_shared_libsan + +-- | Build all stage1+ C/C++ code with UndefinedBehaviorSanitizer +-- support: +-- https://clang.llvm.org/docs/UndefinedBehaviorSanitizer.html +enableUBSan :: Flavour -> Flavour +enableUBSan = + addArgs $ + notStage0 + ? mconcat + [ package rts + ? builder (Cabal Flags) + ? arg "+ubsan" + <> (needSharedLibSAN ? arg "+shared-libsan"), + builder (Ghc CompileHs) ? arg "-optc-fsanitize=undefined", + builder (Ghc CompileCWithGhc) ? arg "-optc-fsanitize=undefined", + builder (Ghc CompileCppWithGhc) ? arg "-optcxx-fsanitize=undefined", + builder (Ghc LinkHs) + ? arg "-optc-fsanitize=undefined" + <> arg "-optl-fsanitize=undefined" + <> (needSharedLibSAN ? arg "-optl-shared-libsan"), + builder (Cc CompileC) ? arg "-fsanitize=undefined", + builder Testsuite ? arg "--config=have_ubsan=True" + ] + -- | Use the LLVM backend in stages 1 and later. viaLlvmBackend :: Flavour -> Flavour viaLlvmBackend = addArgs $ notStage0 ? builder Ghc ? arg "-fllvm" ===================================== rts/.ubsan-suppressions ===================================== @@ -0,0 +1,8 @@ +# libraries/text/cbits/measure_off.c:50:39: runtime left shift of 1 by 31 places cannot be represented in type 'int' +shift-base:libraries/text/cbits/measure_off.c + +# "runtime call to function foo through pointer to incorrect function +# type" is unfortunately pretty common (e.g. evac_fn in rts) and +# impact the signal to noise ratio of UBSan warnings. gcc doesn't +# implement this instrumentation though. +function:* ===================================== rts/Interpreter.c ===================================== @@ -274,12 +274,21 @@ See also Note [Width of parameters] for some more motivation. #define W64_TO_WDS(n) ((n * sizeof(StgWord64) / sizeof(StgWord))) +// Returns a pointer to the stack location. +#define SafeSpWP(n) \ + ( ((WITHIN_CAP_CHUNK_BOUNDS_W(n)) ? Sp_plusW(n) : slow_spw(Sp, cap->r.rCurrentTSO->stackobj, n))) +#define SafeSpBP(off_w) \ + ( (WITHIN_CAP_CHUNK_BOUNDS_W((1+(off_w))/sizeof(StgWord))) ? \ + Sp_plusB(off_w) : \ + (void*)((ptrdiff_t)((ptrdiff_t)(off_w) % (ptrdiff_t)sizeof(StgWord)) + (StgWord8*)slow_spw(Sp, cap->r.rCurrentTSO->stackobj, (off_w)/sizeof(StgWord))) \ + ) + // Always safe to use - Return the value at the address #define ReadSpW(n) (*((StgWord*) SafeSpWP(n))) //Argument is offset in multiples of word64 #define ReadSpW64(n) (*((StgWord64*) SafeSpWP(W64_TO_WDS(n)))) // Perhaps confusingly this still reads a full word, merely the offset is in bytes. -#define ReadSpB(n) (*((StgWord*) SafeSpBP(n))) +#define ReadSpB(n) (*((StgUnalignedWord*) SafeSpBP(n))) /* Note [PUSH_L underflow] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -326,15 +335,6 @@ See ticket #25750 */ -// Returns a pointer to the stack location. -#define SafeSpWP(n) \ - ( ((WITHIN_CAP_CHUNK_BOUNDS_W(n)) ? Sp_plusW(n) : slow_spw(Sp, cap->r.rCurrentTSO->stackobj, n))) -#define SafeSpBP(off_w) \ - ( (WITHIN_CAP_CHUNK_BOUNDS_W((1+(off_w))/sizeof(StgWord))) ? \ - Sp_plusB(off_w) : \ - (void*)((ptrdiff_t)((ptrdiff_t)(off_w) % (ptrdiff_t)sizeof(StgWord)) + (StgWord8*)slow_spw(Sp, cap->r.rCurrentTSO->stackobj, (off_w)/sizeof(StgWord))) \ - ) - /* Note [Interpreter subword primops] @@ -2904,6 +2904,8 @@ run_BCO: NEXT_INSTRUCTION; \ } +#define TYPE_IS_SIGNED(ty) ((ty)-1 < (ty)1) + // op :: ty -> ty -> ty #define SIZED_BIN_OP(op,ty) \ { \ @@ -2911,8 +2913,12 @@ run_BCO: ty r = ((ty) ReadSpW64(0)) op ((ty) ReadSpW64(1)); \ Sp_addW64(1); \ SpW64(0) = (StgWord64) r; \ + } else if (TYPE_IS_SIGNED(ty)) { \ + ty r = ((StgInt)(ty)ReadSpW(0)) op ((StgInt)(ty)ReadSpW(1)); \ + Sp_addW(1); \ + SpW(0) = (StgWord) r; \ } else { \ - ty r = ((ty) ReadSpW(0)) op ((ty) ReadSpW(1)); \ + ty r = ((StgWord)(ty)ReadSpW(0)) op ((StgWord)(ty)ReadSpW(1)); \ Sp_addW(1); \ SpW(0) = (StgWord) r; \ }; \ @@ -2949,12 +2955,12 @@ run_BCO: NEXT_INSTRUCTION; \ } - INSTRUCTION(bci_OP_ADD_64): SIZED_BIN_OP(+, StgInt64) - INSTRUCTION(bci_OP_SUB_64): SIZED_BIN_OP(-, StgInt64) - INSTRUCTION(bci_OP_AND_64): SIZED_BIN_OP(&, StgInt64) - INSTRUCTION(bci_OP_XOR_64): SIZED_BIN_OP(^, StgInt64) - INSTRUCTION(bci_OP_OR_64): SIZED_BIN_OP(|, StgInt64) - INSTRUCTION(bci_OP_MUL_64): SIZED_BIN_OP(*, StgInt64) + INSTRUCTION(bci_OP_ADD_64): SIZED_BIN_OP(+, StgWord64) + INSTRUCTION(bci_OP_SUB_64): SIZED_BIN_OP(-, StgWord64) + INSTRUCTION(bci_OP_AND_64): SIZED_BIN_OP(&, StgWord64) + INSTRUCTION(bci_OP_XOR_64): SIZED_BIN_OP(^, StgWord64) + INSTRUCTION(bci_OP_OR_64): SIZED_BIN_OP(|, StgWord64) + INSTRUCTION(bci_OP_MUL_64): SIZED_BIN_OP(*, StgWord64) INSTRUCTION(bci_OP_SHL_64): SIZED_BIN_OP_TY_INT(<<, StgWord64) INSTRUCTION(bci_OP_LSR_64): SIZED_BIN_OP_TY_INT(>>, StgWord64) INSTRUCTION(bci_OP_ASR_64): SIZED_BIN_OP_TY_INT(>>, StgInt64) @@ -2972,15 +2978,15 @@ run_BCO: INSTRUCTION(bci_OP_S_LE_64): SIZED_BIN_OP_TY_TY_INT(<=, StgInt64) INSTRUCTION(bci_OP_NOT_64): UN_SIZED_OP(~, StgWord64) - INSTRUCTION(bci_OP_NEG_64): UN_SIZED_OP(-, StgInt64) + INSTRUCTION(bci_OP_NEG_64): UN_SIZED_OP(-, StgWord64) - INSTRUCTION(bci_OP_ADD_32): SIZED_BIN_OP(+, StgInt32) - INSTRUCTION(bci_OP_SUB_32): SIZED_BIN_OP(-, StgInt32) - INSTRUCTION(bci_OP_AND_32): SIZED_BIN_OP(&, StgInt32) - INSTRUCTION(bci_OP_XOR_32): SIZED_BIN_OP(^, StgInt32) - INSTRUCTION(bci_OP_OR_32): SIZED_BIN_OP(|, StgInt32) - INSTRUCTION(bci_OP_MUL_32): SIZED_BIN_OP(*, StgInt32) + INSTRUCTION(bci_OP_ADD_32): SIZED_BIN_OP(+, StgWord32) + INSTRUCTION(bci_OP_SUB_32): SIZED_BIN_OP(-, StgWord32) + INSTRUCTION(bci_OP_AND_32): SIZED_BIN_OP(&, StgWord32) + INSTRUCTION(bci_OP_XOR_32): SIZED_BIN_OP(^, StgWord32) + INSTRUCTION(bci_OP_OR_32): SIZED_BIN_OP(|, StgWord32) + INSTRUCTION(bci_OP_MUL_32): SIZED_BIN_OP(*, StgWord32) INSTRUCTION(bci_OP_SHL_32): SIZED_BIN_OP_TY_INT(<<, StgWord32) INSTRUCTION(bci_OP_LSR_32): SIZED_BIN_OP_TY_INT(>>, StgWord32) INSTRUCTION(bci_OP_ASR_32): SIZED_BIN_OP_TY_INT(>>, StgInt32) @@ -2998,15 +3004,15 @@ run_BCO: INSTRUCTION(bci_OP_S_LE_32): SIZED_BIN_OP_TY_TY_INT(<=, StgInt32) INSTRUCTION(bci_OP_NOT_32): UN_SIZED_OP(~, StgWord32) - INSTRUCTION(bci_OP_NEG_32): UN_SIZED_OP(-, StgInt32) + INSTRUCTION(bci_OP_NEG_32): UN_SIZED_OP(-, StgWord32) - INSTRUCTION(bci_OP_ADD_16): SIZED_BIN_OP(+, StgInt16) - INSTRUCTION(bci_OP_SUB_16): SIZED_BIN_OP(-, StgInt16) - INSTRUCTION(bci_OP_AND_16): SIZED_BIN_OP(&, StgInt16) - INSTRUCTION(bci_OP_XOR_16): SIZED_BIN_OP(^, StgInt16) - INSTRUCTION(bci_OP_OR_16): SIZED_BIN_OP(|, StgInt16) - INSTRUCTION(bci_OP_MUL_16): SIZED_BIN_OP(*, StgInt16) + INSTRUCTION(bci_OP_ADD_16): SIZED_BIN_OP(+, StgWord16) + INSTRUCTION(bci_OP_SUB_16): SIZED_BIN_OP(-, StgWord16) + INSTRUCTION(bci_OP_AND_16): SIZED_BIN_OP(&, StgWord16) + INSTRUCTION(bci_OP_XOR_16): SIZED_BIN_OP(^, StgWord16) + INSTRUCTION(bci_OP_OR_16): SIZED_BIN_OP(|, StgWord16) + INSTRUCTION(bci_OP_MUL_16): SIZED_BIN_OP(*, StgWord16) INSTRUCTION(bci_OP_SHL_16): SIZED_BIN_OP_TY_INT(<<, StgWord16) INSTRUCTION(bci_OP_LSR_16): SIZED_BIN_OP_TY_INT(>>, StgWord16) INSTRUCTION(bci_OP_ASR_16): SIZED_BIN_OP_TY_INT(>>, StgInt16) @@ -3024,15 +3030,15 @@ run_BCO: INSTRUCTION(bci_OP_S_LE_16): SIZED_BIN_OP(<=, StgInt16) INSTRUCTION(bci_OP_NOT_16): UN_SIZED_OP(~, StgWord16) - INSTRUCTION(bci_OP_NEG_16): UN_SIZED_OP(-, StgInt16) + INSTRUCTION(bci_OP_NEG_16): UN_SIZED_OP(-, StgWord16) - INSTRUCTION(bci_OP_ADD_08): SIZED_BIN_OP(+, StgInt8) - INSTRUCTION(bci_OP_SUB_08): SIZED_BIN_OP(-, StgInt8) - INSTRUCTION(bci_OP_AND_08): SIZED_BIN_OP(&, StgInt8) - INSTRUCTION(bci_OP_XOR_08): SIZED_BIN_OP(^, StgInt8) - INSTRUCTION(bci_OP_OR_08): SIZED_BIN_OP(|, StgInt8) - INSTRUCTION(bci_OP_MUL_08): SIZED_BIN_OP(*, StgInt8) + INSTRUCTION(bci_OP_ADD_08): SIZED_BIN_OP(+, StgWord8) + INSTRUCTION(bci_OP_SUB_08): SIZED_BIN_OP(-, StgWord8) + INSTRUCTION(bci_OP_AND_08): SIZED_BIN_OP(&, StgWord8) + INSTRUCTION(bci_OP_XOR_08): SIZED_BIN_OP(^, StgWord8) + INSTRUCTION(bci_OP_OR_08): SIZED_BIN_OP(|, StgWord8) + INSTRUCTION(bci_OP_MUL_08): SIZED_BIN_OP(*, StgWord8) INSTRUCTION(bci_OP_SHL_08): SIZED_BIN_OP_TY_INT(<<, StgWord8) INSTRUCTION(bci_OP_LSR_08): SIZED_BIN_OP_TY_INT(>>, StgWord8) INSTRUCTION(bci_OP_ASR_08): SIZED_BIN_OP_TY_INT(>>, StgInt8) @@ -3050,7 +3056,7 @@ run_BCO: INSTRUCTION(bci_OP_S_LE_08): SIZED_BIN_OP_TY_TY_INT(<=, StgInt8) INSTRUCTION(bci_OP_NOT_08): UN_SIZED_OP(~, StgWord8) - INSTRUCTION(bci_OP_NEG_08): UN_SIZED_OP(-, StgInt8) + INSTRUCTION(bci_OP_NEG_08): UN_SIZED_OP(-, StgWord8) INSTRUCTION(bci_OP_INDEX_ADDR_64): { @@ -3130,7 +3136,7 @@ run_BCO: StgPtr p; W_ ret[2]; // max needed W_ *arguments[stk_offset]; // max needed - void *argptrs[nargs]; + void *argptrs[nargs > 0 ? nargs : 1]; // the size of a variable length array must be positive void (*fn)(void); if (cif->rtype == &ffi_type_void) { ===================================== rts/include/stg/Types.h ===================================== @@ -147,6 +147,8 @@ typedef uint16_t StgHalfWord; #error GHC untested on this architecture: sizeof(void *) != 4 or 8 #endif +typedef StgWord StgUnalignedWord __attribute__((aligned(1))); + #define W_MASK (sizeof(W_)-1) /* ===================================== rts/rts.cabal ===================================== @@ -91,6 +91,19 @@ flag thread-sanitizer in @rts/include/rts/TSANUtils.h@. default: False manual: True +flag ubsan + description: + Link with -fsanitize=undefined, to be enabled when building with + UndefinedBehaviorSanitizer. + default: False + manual: True +flag shared-libsan + description: + Link with -shared-libsan, to guarantee only one copy of the + sanitizer runtimes exist in the address space. See + needSharedLibSAN in hadrian/src/Flavour.hs. + default: False + manual: True library -- rts is a wired in package and @@ -200,6 +213,12 @@ library cc-options: -fsanitize=thread ld-options: -fsanitize=thread + if flag(ubsan) + ld-options: -fsanitize=undefined + + if flag(shared-libsan) + ld-options: -shared-libsan + if os(linux) -- the RTS depends upon libc. while this dependency is generally -- implicitly added by `cc`, we must explicitly add it here to ensure ===================================== testsuite/driver/testglobals.py ===================================== @@ -186,6 +186,9 @@ class TestConfig: # Are we running in a ThreadSanitizer-instrumented build? self.have_thread_sanitizer = False + # Are we running with UndefinedBehaviorSanitizer enabled? + self.have_ubsan = False + # Do symbols use leading underscores? self.leading_underscore = False ===================================== testsuite/driver/testlib.py ===================================== @@ -1090,6 +1090,8 @@ def llvm_build ( ) -> bool: def have_thread_sanitizer( ) -> bool: return config.have_thread_sanitizer +def have_ubsan( ) -> bool: + return config.have_ubsan def gcc_as_cmmp() -> bool: return config.cmm_cpp_is_gcc View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/310bf01b52db3b2ca6416170662d32… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/310bf01b52db3b2ca6416170662d32… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fix-eventlog-flush-deadlock] 21 commits: template-haskell: Better describe getQ semantics
by Matthew Pickering (＠mpickering) 25 Nov '25

25 Nov '25

Matthew Pickering pushed to branch wip/fix-eventlog-flush-deadlock at Glasgow Haskell Compiler / GHC Commits: 741da00c by Ben Gamari at 2025-11-12T03:38:20-05:00 template-haskell: Better describe getQ semantics Clarify that the state is a type-indexed map, as suggested by #26484. - - - - - 8b080e04 by ARATA Mizuki at 2025-11-12T03:39:11-05:00 Fix incorrect markups in the User's Guide * Correct markup for C--: "C-\-" in reST * Fix internal links * Fix code highlighting * Fix inline code: Use ``code`` rather than `code` * Remove extra backslashes Fixes #16812 Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> - - - - - a00840ea by Simon Peyton Jones at 2025-11-14T15:23:56+00:00 Make TYPE and CONSTRAINT apart again This patch finally fixes #24279. * The story started with #11715 * Then #21623 articulated a plan, which made Type and Constraint not-apart; a horrible hack but it worked. The main patch was commit 778c6adca2c995cd8a1b84394d4d5ca26b915dac Author: Simon Peyton Jones <simonpj(a)microsoft.com> Date: Wed Nov 9 10:33:22 2022 +0000 Type vs Constraint: finally nailed * #24279 reported a bug in the above big commit; this small patch fixes it commit af6932d6c068361c6ae300d52e72fbe13f8e1f18 Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com> Date: Mon Jan 8 10:49:49 2024 +0000 Make TYPE and CONSTRAINT not-apart Issue #24279 showed up a bug in the logic in GHC.Core.Unify.unify_ty which is supposed to make TYPE and CONSTRAINT be not-apart. * Then !10479 implemented "unary classes". * That change in turn allows us to make Type and Constraint apart again, cleaning up the compiler and allowing a little bit more expressiveness. It fixes the original hope in #24279, namely that `Type` and `Constraint` should be distinct throughout. - - - - - c0a1e574 by Georgios Karachalias at 2025-11-15T05:14:31-05:00 Report all missing modules with -M We now report all missing modules at once in GHC.Driver.Makefile.processDeps, as opposed to only reporting a single missing module. Fixes #26551. - - - - - c9fa3449 by Sylvain Henry at 2025-11-15T05:15:26-05:00 JS: fix array index for registers We used to store R32 in h$regs[-1]. While it's correct in JavaScript, fix this to store R32 in h$regs[0] instead. - - - - - 9e469909 by Sylvain Henry at 2025-11-15T05:15:26-05:00 JS: support more than 128 registers (#26558) The JS backend only supported 128 registers (JS variables/array slots used to pass function arguments). It failed in T26537 when 129 registers were required. This commit adds support for more than 128 registers: it is now limited to maxBound :: Int (compiler's Int). If we ever go above this threshold the compiler now panics with a more descriptive message. A few built-in JS functions were assuming 128 registers and have been rewritten to use loops. Note that loops are only used for "high" registers that are stored in an array: the 31 "low" registers are still handled with JS global variables and with explicit switch-cases to maintain good performance in the most common cases (i.e. few registers used). Adjusting the number of low registers is now easy: just one constant to adjust (GHC.StgToJS.Regs.lowRegsCount). No new test added: T26537 is used as a regression test instead. - - - - - 0a64a78b by Sven Tennie at 2025-11-15T20:31:10-05:00 AArch64: Simplify CmmAssign and CmmStore The special handling for floats was fake: The general case is always used. So, the additional code path isn't needed (and only adds complexity for the reader.) - - - - - 15b311be by sheaf at 2025-11-15T20:32:02-05:00 SimpleOpt: refactor & push coercions into lambdas This commit improves the simple optimiser (in GHC.Core.SimpleOpt) in a couple of ways: - The logic to push coercion lambdas is shored up. The function 'pushCoercionIntoLambda' used to be called in 'finish_app', but this meant we could not continue to optimise the program after performing this transformation. Now, we call 'pushCoercionIntoLambda' as part of 'simple_app'. Doing so can be important when dealing with unlifted newtypes, as explained in Note [Desugaring unlifted newtypes]. - The code is re-structured to avoid duplication and out-of-sync code paths. Now, 'simple_opt_expr' defers to 'simple_app' for the 'App', 'Var', 'Cast' and 'Lam' cases. This means all the logic for those is centralised in a single place (e.g. the 'go_lam' helper function). To do this, the general structure is brought a bit closer to the full-blown simplifier, with a notion of 'continuation' (see 'SimpleContItem'). This commit also modifies GHC.Core.Opt.Arity.pushCoercionIntoLambda to apply a substitution (a slight generalisation of its existing implementation). - - - - - b33284c7 by sheaf at 2025-11-15T20:32:02-05:00 Improve typechecking of data constructors This commit changes the way in which we perform typecheck data constructors, in particular how we make multiplicities line up. Now, impedance matching occurs as part of the existing subsumption machinery. See the revamped Note [Typechecking data constructors] in GHC.Tc.Gen.App, as well as Note [Polymorphisation of linear fields] in GHC.Core.Multiplicity. This allows us to get rid of a fair amount of hacky code that was added with the introduction of LinearTypes; in particular the logic of GHC.Tc.Gen.Head.tcInferDataCon. ------------------------- Metric Decrease: T10421 T14766 T15164 T15703 T19695 T5642 T9630 WWRec ------------------------- - - - - - b6faf5d0 by sheaf at 2025-11-15T20:32:02-05:00 Handle unsaturated rep-poly newtypes This commit allows GHC to handle unsaturated occurrences of unlifted newtype constructors. The plan is detailed in Note [Eta-expanding rep-poly unlifted newtypes] in GHC.Tc.Utils.Concrete: for unsaturated unlifted newtypes, we perform the appropriate representation-polymorphism check in tcInstFun. - - - - - 682bf979 by Mike Pilgrem at 2025-11-16T16:44:14+00:00 Fix #26293 Valid stack.yaml for hadrian - - - - - acc70c3a by Simon Peyton Jones at 2025-11-18T16:21:20-05:00 Fix a bug in defaulting Addresses #26582 Defaulting was doing some unification but then failing to iterate. Silly. I discovered that the main solver was unnecessarily iterating even if there was a unification for an /outer/ unification variable, so I fixed that too. - - - - - c12fa73e by Simon Peyton Jones at 2025-11-19T02:55:01-05:00 Make PmLit be in Ord, and use it in Map This MR addresses #26514, by changing from data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit] to data PmAltConSet = PACS !(UniqDSet ConLike) !(Map PmLit PmLit) This matters when doing pattern-match overlap checking, when there is a very large set of patterns. For most programs it makes no difference at all. For the N=5000 case of the repro case in #26514, compiler mutator time (with `-fno-code`) goes from 1.9s to 0.43s. All for the price for an Ord instance for PmLit - - - - - 41b84f40 by sheaf at 2025-11-19T02:55:52-05:00 Add passing tests for #26311 and #26072 This commit adds two tests cases that now pass since landing the changes to typechecking of data constructors in b33284c7. Fixes #26072 #26311 - - - - - 1faa758a by sheaf at 2025-11-19T02:55:52-05:00 mkCast: weaken bad cast warning for multiplicity This commit weakens the warning message emitted when constructing a bad cast in mkCast to ignore multiplicity. Justification: since b33284c7, GHC uses sub-multiplicity coercions to typecheck data constructors. The coercion optimiser is free to discard these coercions, both for performance reasons, and because GHC's Core simplifier does not (yet) preserve linearity. We thus weaken 'mkCast' to use 'eqTypeIgnoringMultiplicity' instead of 'eqType', to avoid getting many spurious warnings about mismatched multiplicities. - - - - - 55eab80d by Sylvain Henry at 2025-11-20T17:33:13-05:00 Build external interpreter program on demand (#24731) This patch teaches GHC how to build the external interpreter program when it is missing. As long as we have the `ghci` library, doing this is trivial so most of this patch is refactoring for doing it sanely. - - - - - 08bbc028 by Rodrigo Mesquita at 2025-11-20T17:33:54-05:00 Add tests for #23973 and #26565 These were fixed by 4af4f0f070f83f948e49ad5d7835fd91b8d3f0e6 in !10417 - - - - - 6b42232c by sheaf at 2025-11-20T17:34:35-05:00 Mark T26410_ffi as fragile on Windows As seen in #26595, this test intermittently fails on Windows. This commit marks it as fragile, until we get around to fixing it. - - - - - b7b7c049 by Andrew Lelechenko at 2025-11-21T21:04:01+00:00 Add nubOrd / nubOrdBy to Data.List and Data.List.NonEmpty As per https://github.com/haskell/core-libraries-committee/issues/336 - - - - - 352d5462 by Marc Scholten at 2025-11-22T10:33:03-05:00 Fix haddock test runner to handle UTF-8 output xhtml 3000.4.0.0 now produces UTF-8 output instead of escaping non-ASCII characters. When using --test-accept it previously wrote files in the wrong encoding because they have not been decoded properly when reading the files. - - - - - 2cf1b3a1 by Matthew Pickering at 2025-11-25T11:37:14+00:00 rts: Fix a deadlock with eventlog flush interval and RTS shutdown The ghc_ticker thread attempts to flush at the eventlog tick interval, this requires waiting to take all capabilities. At the same time, the main thread is shutting down, the schedule is stopped and then we wait for the ticker thread to finish. Therefore we are deadlocked. The solution is to use `newBoundTask/exitMyTask`, so that flushing can cooperate with the scheduler shutdown. Fixes #26573 - - - - - 179 changed files: - compiler/GHC.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Multiplicity.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/RoughMap.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Driver/Config/Core/Lint.hs - + compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/Config/Linker.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/Linker/Config.hs - compiler/GHC/Linker/Dynamic.hs - + compiler/GHC/Linker/Executable.hs - − compiler/GHC/Linker/ExtraObj.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/MacOS.hs - compiler/GHC/Linker/Static.hs - compiler/GHC/Linker/Windows.hs - + compiler/GHC/Runtime/Interpreter/C.hs - + compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Regs.hs - compiler/GHC/StgToJS/Rts/Rts.hs - compiler/GHC/StgToJS/Rts/Types.hs - compiler/GHC/SysTools/Tasks.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Concrete.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/SourceText.hs - compiler/ghc.cabal.in - docs/users_guide/9.16.1-notes.rst - docs/users_guide/bugs.rst - docs/users_guide/debug-info.rst - docs/users_guide/debugging.rst - docs/users_guide/extending_ghc.rst - docs/users_guide/exts/arrows.rst - docs/users_guide/exts/derive_any_class.rst - docs/users_guide/exts/deriving_extra.rst - docs/users_guide/exts/deriving_inferred.rst - docs/users_guide/exts/deriving_strategies.rst - docs/users_guide/exts/gadt.rst - docs/users_guide/exts/generics.rst - docs/users_guide/exts/overloaded_labels.rst - docs/users_guide/exts/overloaded_strings.rst - docs/users_guide/exts/pattern_synonyms.rst - docs/users_guide/exts/poly_kinds.rst - docs/users_guide/exts/primitives.rst - docs/users_guide/exts/rank_polymorphism.rst - docs/users_guide/exts/rebindable_syntax.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/exts/scoped_type_variables.rst - docs/users_guide/exts/standalone_deriving.rst - docs/users_guide/exts/template_haskell.rst - docs/users_guide/exts/tuple_sections.rst - docs/users_guide/exts/type_data.rst - docs/users_guide/exts/type_defaulting.rst - docs/users_guide/gone_wrong.rst - docs/users_guide/hints.rst - docs/users_guide/javascript.rst - docs/users_guide/phases.rst - docs/users_guide/profiling.rst - docs/users_guide/separate_compilation.rst - docs/users_guide/using.rst - docs/users_guide/wasm.rst - docs/users_guide/win32-dlls.rst - hadrian/stack.yaml - hadrian/stack.yaml.lock - libraries/base/base.cabal.in - libraries/base/changelog.md - libraries/base/src/Data/List.hs - libraries/base/src/Data/List/NonEmpty.hs - + libraries/base/src/Data/List/NubOrdSet.hs - libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - rts/eventlog/EventLog.c - + testsuite/tests/bytecode/T23973.hs - + testsuite/tests/bytecode/T23973.script - + testsuite/tests/bytecode/T23973.stdout - + testsuite/tests/bytecode/T26565.hs - + testsuite/tests/bytecode/T26565.script - + testsuite/tests/bytecode/T26565.stdout - testsuite/tests/bytecode/all.T - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/diagnostic-codes/codes.stdout - testsuite/tests/driver/Makefile - + testsuite/tests/driver/T24731.hs - + testsuite/tests/driver/T26551.hs - + testsuite/tests/driver/T26551.stderr - testsuite/tests/driver/all.T - testsuite/tests/ghci/scripts/T8959b.stderr - testsuite/tests/ghci/scripts/ghci051.stderr - testsuite/tests/indexed-types/should_compile/T12538.stderr - testsuite/tests/indexed-types/should_fail/T21092.hs - − testsuite/tests/indexed-types/should_fail/T21092.stderr - testsuite/tests/indexed-types/should_fail/all.T - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - + testsuite/tests/linear/should_compile/LinearEtaExpansions.hs - testsuite/tests/linear/should_compile/all.T - testsuite/tests/linear/should_fail/TypeClass.hs - testsuite/tests/linear/should_fail/TypeClass.stderr - testsuite/tests/linear/should_run/LinearGhci.stdout - + testsuite/tests/linear/should_run/T26311.hs - + testsuite/tests/linear/should_run/T26311.stdout - testsuite/tests/linear/should_run/all.T - testsuite/tests/numeric/should_compile/T16402.stderr-ws-64 - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/perf/compiler/all.T - testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr - testsuite/tests/rep-poly/RepPolyCase1.stderr - − testsuite/tests/rep-poly/RepPolyCase2.stderr - testsuite/tests/rep-poly/RepPolyRule3.stderr - testsuite/tests/rep-poly/RepPolyTuple4.stderr - testsuite/tests/rep-poly/T13233.stderr - − testsuite/tests/rep-poly/T17021.stderr - testsuite/tests/rep-poly/T20363b.stderr - − testsuite/tests/rep-poly/T21650_a.stderr - − testsuite/tests/rep-poly/T21650_b.stderr - + testsuite/tests/rep-poly/T26072.hs - + testsuite/tests/rep-poly/T26072b.hs - testsuite/tests/rep-poly/UnliftedNewtypesLevityBinder.stderr - testsuite/tests/rep-poly/all.T - testsuite/tests/rts/all.T - testsuite/tests/simd/should_run/all.T - + testsuite/tests/typecheck/should_compile/T26582.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_fail/T15883e.stderr - testsuite/tests/typecheck/should_fail/T2414.stderr - testsuite/tests/typecheck/should_fail/T24279.hs - − testsuite/tests/typecheck/should_fail/T24279.stderr - testsuite/tests/typecheck/should_fail/T2534.stderr - testsuite/tests/typecheck/should_fail/T7264.stderr - testsuite/tests/typecheck/should_fail/all.T - utils/haddock/haddock-test/src/Test/Haddock.hs - utils/haddock/hypsrc-test/ref/src/Classes.html - utils/haddock/hypsrc-test/ref/src/Quasiquoter.html - utils/iserv/iserv.cabal.in The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/14a4fb8df33802d9fdf29b8156b386… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/14a4fb8df33802d9fdf29b8156b386… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/amg/castz] 3 commits: Avoid castCoToCo in tryCastWorkerWrapper
by Adam Gundry (＠adamgundry) 25 Nov '25

25 Nov '25

Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC Commits: 0868a190 by Adam Gundry at 2025-11-24T16:22:48+00:00 Avoid castCoToCo in tryCastWorkerWrapper - - - - - 6596d839 by Adam Gundry at 2025-11-25T10:22:41+00:00 WIP: avoid castCoToCo in the optimizer - - - - - 58a31cb9 by Adam Gundry at 2025-11-25T10:23:02+00:00 WIP: use CastCoercion in rule matcher - - - - - 12 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/Map/Type.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/Utils.hs Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -56,6 +56,14 @@ module GHC.Core.Coercion ( -- ** Cast coercions castCoToCo, mkTransCastCo, mkTransCastCoCo, mkTransCoCastCo, + mkSymCastCo, + mkPiCastCos, + isReflCastCo, + checkReflexiveCastCo, + coToCastCo, + mkForAllCastCo, + mkFunResCastCo, + mkFunCastCoNoFTF, -- ** Decomposition instNewTyCon_maybe, @@ -82,7 +90,7 @@ module GHC.Core.Coercion ( coToMCo, kindCoToMKindCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo, - mkFunResMCo, mkPiMCos, + mkFunResMCo, isReflMCo, checkReflexiveMCo, -- ** Coercion variables @@ -389,13 +397,10 @@ mkCastTyMCo :: Type -> MCoercion -> Type mkCastTyMCo ty MRefl = ty mkCastTyMCo ty (MCo co) = ty `mkCastTy` co -mkPiMCos :: [Var] -> MCoercion -> MCoercion -mkPiMCos _ MRefl = MRefl -mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co) - -mkFunResMCo :: Id -> MCoercionR -> MCoercionR -mkFunResMCo _ MRefl = MRefl -mkFunResMCo arg_id (MCo co) = MCo (mkFunResCo Representational arg_id co) +mkFunResMCo :: Id -> CastCoercion -> CastCoercion +mkFunResMCo _ ReflCastCo = ReflCastCo +mkFunResMCo arg_id (CCoercion co) = CCoercion (mkFunResCo Representational arg_id co) +mkFunResMCo arg_id (ZCoercion ty cos) = ZCoercion (mkFunctionType (idMult arg_id) (varType arg_id) ty) cos -- TODO check type mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion mkGReflLeftMCo r ty MRefl = mkReflCo r ty @@ -842,6 +847,17 @@ mkFunCoNoFTF r w arg_co res_co Pair argl_ty argr_ty = coercionKind arg_co Pair resl_ty resr_ty = coercionKind res_co +-- AMG TODO: more cases here, or maybe better to have a FunCo constructor of CastCoercion? +mkFunCastCoNoFTF :: HasDebugCallStack => Role -> Mult -> Type -> CastCoercion -> Type -> CastCoercion -> CastCoercion +mkFunCastCoNoFTF _ mult _ (ZCoercion arg_ty arg_cos) _ (ZCoercion res_ty res_cos) = ZCoercion (mkFunctionType mult arg_ty res_ty) (arg_cos `unionVarSet` res_cos) +mkFunCastCoNoFTF _ mult _ (ZCoercion arg_ty arg_cos) res_ty res_co = ZCoercion (mkFunctionType mult arg_ty (castCoercionRKind res_ty res_co)) (arg_cos `unionVarSet` coVarsOfCastCo res_co) +mkFunCastCoNoFTF _ mult arg_ty arg_co _ (ZCoercion res_ty res_cos) = ZCoercion (mkFunctionType mult (castCoercionRKind arg_ty arg_co) res_ty) (res_cos `unionVarSet` coVarsOfCastCo arg_co) +mkFunCastCoNoFTF r mult _ (CCoercion arg_co) _ (CCoercion res_co) = CCoercion (mkFunCoNoFTF r (multToCo mult) arg_co res_co) +mkFunCastCoNoFTF _ _ _ ReflCastCo _ ReflCastCo = ReflCastCo +mkFunCastCoNoFTF r mult _ (CCoercion arg_co) res_ty ReflCastCo = CCoercion (mkFunCoNoFTF r (multToCo mult) arg_co (mkReflCo r res_ty)) +mkFunCastCoNoFTF r mult arg_ty ReflCastCo _ (CCoercion res_co) = CCoercion (mkFunCoNoFTF r (multToCo mult) (mkReflCo r arg_ty) res_co) + + -- | Build a function 'Coercion' from two other 'Coercion's. That is, -- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@ -- or @(a => x) ~ (b => y)@, depending on the kind of @a@/@b@. @@ -968,6 +984,13 @@ mkForAllCo v visL visR kind_co co | otherwise = mk_forall_co v visL visR kind_co co +mkForAllCastCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag + -> CastCoercion -> CastCoercion +mkForAllCastCo v visL visR cco = case cco of + CCoercion co -> CCoercion (mkForAllCo v visL visR MRefl co) + ZCoercion ty cos -> ZCoercion (mkTyCoForAllTy v visL ty) cos + ReflCastCo -> ReflCastCo + -- mkForAllVisCos [tv{vis}] constructs a cast -- forall tv. res ~R# forall tv{vis} res`. -- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep @@ -1187,6 +1210,14 @@ mkSymCo co@(ForAllCo { fco_kind = kco, fco_body = body_co }) | isReflMCo kco = co { fco_body = mkSymCo body_co } mkSymCo co = SymCo co +-- | Variant of 'mkSymCo' that works on 'CastCoercion', and expects the LHS type +-- of the input coercion (and hence the RHS type of the result coercion) to be +-- passed in. +mkSymCastCo :: Type -> CastCoercion -> CastCoercion +mkSymCastCo _ (CCoercion co) = CCoercion (mkSymCo co) +mkSymCastCo ty (ZCoercion _ cos) = ZCoercion ty cos +mkSymCastCo _ ReflCastCo = ReflCastCo + -- | mkTransCo creates a new 'Coercion' by composing the two -- given 'Coercion's transitively: (co1 ; co2) mkTransCo :: HasDebugCallStack => Coercion -> Coercion -> Coercion @@ -1765,6 +1796,9 @@ castCoercionKind g h1 h2 mkPiCos :: Role -> [Var] -> Coercion -> Coercion mkPiCos r vs co = foldr (mkPiCo r) co vs +mkPiCastCos :: Role -> [Var] -> CastCoercion -> CastCoercion +mkPiCastCos r vs co = foldr (mkPiCastCo r) co vs + -- | Make a forall 'Coercion', where both types related by the coercion -- are quantified over the same variable. mkPiCo :: Role -> Var -> Coercion -> Coercion @@ -1778,6 +1812,16 @@ mkPiCo r v co | isTyVar v = mkHomoForAllCo v co mkFunResCo r v co | otherwise = mkFunResCo r v co +mkPiCastCo :: Role -> Var -> CastCoercion -> CastCoercion +mkPiCastCo _ _ ReflCastCo = ReflCastCo +mkPiCastCo r v (CCoercion co) = CCoercion (mkPiCo r v co) +mkPiCastCo r v (ZCoercion ty cos) + | isTyVar v = ZCoercion (mkForAllTy (Bndr v vis) ty) cos + | otherwise = ZCoercion (mkFunctionType (idMult v) (varType v) ty) cos + where + vis = coreTyLamForAllTyFlag + + mkFunResCo :: Role -> Id -> Coercion -> Coercion -- Given res_co :: res1 ~ res2, -- mkFunResCo r m arg res_co :: (arg -> res1) ~r (arg -> res2) @@ -1788,6 +1832,13 @@ mkFunResCo role id res_co arg_co = mkReflCo role (varType id) mult = multToCo (idMult id) +mkFunResCastCo :: Role -> Id -> CastCoercion -> CastCoercion +mkFunResCastCo role id res_cco = case res_cco of + CCoercion res_co -> CCoercion (mkFunResCo role id res_co) + ZCoercion ty cos -> ZCoercion (mkFunctionType (idMult id) (varType id) ty) cos + ReflCastCo -> ReflCastCo + + -- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 -- The first coercion might be lifted or unlifted; thus the ~? above -- Lifted and unlifted equalities take different numbers of arguments, @@ -2873,7 +2924,7 @@ See Note [Zapped casts] in GHC.Core.TyCo.Rep. -- but requires the type to be supplied by the caller because it cannot be -- recovered in the 'ZCoercion' case. castCoercionLKind :: HasDebugCallStack => Type -> CastCoercion -> Type -castCoercionLKind _ (CCoercion co) = coercionLKind co +castCoercionLKind _ (CCoercion co) = coercionLKind co -- TODO: should we use provided lhs_ty instead? Not sure which is cheaper? castCoercionLKind lhs_ty (ZCoercion _ _) = lhs_ty castCoercionLKind lhs_ty ReflCastCo = lhs_ty @@ -2922,9 +2973,27 @@ mkTransCoCastCo co1 (CCoercion co2) = CCoercion (mkTransCo co1 co2) mkTransCoCastCo co1 (ZCoercion ty cos) = ZCoercion ty (shallowCoVarsOfCo co1 `unionVarSet` cos) mkTransCoCastCo co1 ReflCastCo = CCoercion co1 +-- | Quickly check if a 'CastCoercion' is obviously reflexive. +isReflCastCo :: CastCoercion -> Bool +isReflCastCo (CCoercion co) = isReflCo co +isReflCastCo ZCoercion{} = False -- it might be, but we can't tell +isReflCastCo ReflCastCo = True + -- | Slowly checks if the coercion is reflexive. Don't call this in a loop, -- as it walks over the entire coercion. isReflexiveCastCo :: Type -> CastCoercion -> Bool isReflexiveCastCo _ (CCoercion co) = isReflexiveCo co isReflexiveCastCo lhs_ty (ZCoercion rhs_ty _) = lhs_ty `eqType` rhs_ty isReflexiveCastCo _ ReflCastCo = True + +checkReflexiveCastCo :: Type -> CastCoercion -> CastCoercion +checkReflexiveCastCo ty cco + | isReflexiveCastCo ty cco = ReflCastCo + | otherwise = cco + +coToCastCo :: Coercion -> CastCoercion +-- Convert a coercion to a CastCoercion, checking if it is obviously reflexive. +-- It's not clear whether or not isReflexiveCo would be better here +-- See #19815 for a bit of data and discussion on this point +coToCastCo co | isReflCo co = ReflCastCo + | otherwise = CCoercion co ===================================== compiler/GHC/Core/Coercion/Opt.hs ===================================== @@ -4,6 +4,7 @@ module GHC.Core.Coercion.Opt ( optCoercion + , optCastCoercion , OptCoercionOpts (..) ) where @@ -169,6 +170,13 @@ newtype OptCoercionOpts = OptCoercionOpts { optCoercionEnabled :: Bool -- ^ Enable coercion optimisation (reduce its size) } +optCastCoercion :: OptCoercionOpts -> Subst -> Type -> CastCoercion -> CastCoercion +optCastCoercion opts env _ (CCoercion co) = CCoercion (optCoercion opts env co) +optCastCoercion opts env _ ReflCastCo = ReflCastCo +optCastCoercion opts env tyL (ZCoercion tyR cos) + | tyL `eqTypeIgnoringMultiplicity` tyR = ReflCastCo + | otherwise = ZCoercion (substTy env tyR) (substCoVarSet env cos) + optCoercion :: OptCoercionOpts -> Subst -> Coercion -> NormalCo -- ^ optCoercion applies a substitution to a coercion, -- *and* optimises it to reduce its size ===================================== compiler/GHC/Core/Map/Type.hs ===================================== @@ -139,6 +139,7 @@ xtC (D env co) f (CoercionMapX m) -- We should really never care about the contents of a cast coercion. Instead, -- just look up the coercion's RHS type. +-- TODO: do we need this type, or can we just use TypeMap? newtype CastCoercionMap a = CastCoercionMap (CastCoercionMapG a) -- TODO(22292): derive ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -42,7 +42,7 @@ module GHC.Core.Opt.Arity , etaExpandToJoinPoint, etaExpandToJoinPointRule -- ** Coercions and casts - , pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg + , pushCoArg, pushCoArgs, pushCastCoValArg, pushCastCoTyArg , pushCoercionIntoLambda, pushCoDataCon, collectBindersPushingCo ) where @@ -2195,7 +2195,7 @@ Now, when we push that eta_co inward in etaInfoApp: -} -------------- -data EtaInfo = EI [Var] MCoercionR +data EtaInfo = EI [Var] CastCoercion -- See Note [The EtaInfo mechanism] instance Outputable EtaInfo where @@ -2221,11 +2221,10 @@ etaInfoApp in_scope expr eis go subst (Tick t e) eis = Tick (substTickish subst t) (go subst e eis) - go subst (Cast e cco) (EI bs mco) + go subst (Cast e co) (EI bs mco) = go subst e (EI bs mco') where - co = castCoToCo (exprType e) cco -- TODO: can we avoid this? - mco' = checkReflexiveMCo (Core.substCo subst co `mkTransMCoR` mco) + mco' = checkReflexiveCastCo (exprType (Core.substExpr subst e)) (Core.substCastCo subst co `mkTransCastCo` mco) -- See Note [Check for reflexive casts in eta expansion] go subst (Case e b ty alts) eis @@ -2247,13 +2246,13 @@ etaInfoApp in_scope expr eis -- Beta-reduction if possible, pushing any intervening casts past -- the argument. See Note [The EtaInfo mechanism] go subst (Lam v e) (EI (b:bs) mco) - | Just (arg,mco') <- pushMCoArg mco (varToCoreExpr b) + | Just (arg,mco') <- pushCoArg (exprType (Lam v e)) mco (varToCoreExpr b) = go (Core.extendSubst subst v arg) e (EI bs mco') -- Stop pushing down; just wrap the expression up -- See Note [Check for reflexive casts in eta expansion] go subst e (EI bs mco) = Core.substExprSC subst e - `mkCastMCo` checkReflexiveMCo mco + `mkCastCo` checkReflexiveCastCo (exprType e) mco -- TODO check type `mkVarApps` bs -------------- @@ -2263,14 +2262,12 @@ etaInfoAppTy :: Type -> EtaInfo -> Type etaInfoAppTy ty (EI bs mco) = applyTypeToArgs ty1 (map varToCoreExpr bs) where - ty1 = case mco of - MRefl -> ty - MCo co -> coercionRKind co + ty1 = castCoercionRKind ty mco -------------- etaInfoAbs :: EtaInfo -> CoreExpr -> CoreExpr -- See Note [The EtaInfo mechanism] -etaInfoAbs (EI bs mco) expr = (mkLams bs expr) `mkCastMCo` mkSymMCo mco +etaInfoAbs (EI bs mco) expr = (mkLams bs expr) `mkCastCo` mkSymCastCo (error "AMG TODO: etaInfoAbs") mco -------------- -- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding @@ -2307,7 +2304,7 @@ mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty go _ [] subst _ ----------- Done! No more expansion needed - = (substInScopeSet subst, EI [] MRefl) + = (substInScopeSet subst, EI [] ReflCastCo) go n oss@(one_shot:oss1) subst ty ----------- Forall types (forall a. ty) @@ -2348,27 +2345,28 @@ mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty -- we'd have had to zap it for the recursive call) , (in_scope, EI bs mco) <- go n oss subst ty' -- mco :: subst(ty') ~ b1_ty -> ... -> bn_ty -> tr - = (in_scope, EI bs (mkTransMCoR co' mco)) + = (in_scope, EI bs (mkTransCoCastCo co' mco)) | otherwise -- We have an expression of arity > 0, -- but its type isn't a function, or a binder -- does not have a fixed runtime representation = warnPprTrace True "mkEtaWW" ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr) - (substInScopeSet subst, EI [] MRefl) + (substInScopeSet subst, EI [] ReflCastCo) -- This *can* legitimately happen: -- e.g. coerce Int (\x. x) Essentially the programmer is -- playing fast and loose with types (Happy does this a lot). -- So we simply decline to eta-expand. Otherwise we'd end up -- with an explicit lambda having a non-function type -mkEtaForAllMCo :: ForAllTyBinder -> Type -> MCoercion -> MCoercion +mkEtaForAllMCo :: ForAllTyBinder -> Type -> CastCoercion -> CastCoercion mkEtaForAllMCo (Bndr tcv vis) ty mco = case mco of - MRefl | vis == coreTyLamForAllTyFlag -> MRefl - | otherwise -> mk_fco (mkRepReflCo ty) - MCo co -> mk_fco co + ReflCastCo | vis == coreTyLamForAllTyFlag -> ReflCastCo + | otherwise -> mk_fco (mkRepReflCo ty) + CCoercion co -> mk_fco co + ZCoercion ty2 cos -> ZCoercion ty cos -- TODO: is ty right? where - mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag MRefl co) + mk_fco co = CCoercion (mkForAllCo tcv vis coreTyLamForAllTyFlag MRefl co) -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly -- the (EtaInfo Invariant). (sym co) wraps a lambda that always has -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core] @@ -2701,13 +2699,13 @@ same fix. tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> SubDemand -> Maybe CoreExpr -- Return an expression equal to (\bndrs. body) tryEtaReduce rec_ids bndrs body eval_sd - = go (reverse bndrs) body (mkRepReflCo (exprType body)) + = go (reverse bndrs) body ReflCastCo where incoming_arity = count isId bndrs -- See Note [Eta reduction makes sense], point (2) go :: [Var] -- Binders, innermost first, types [a3,a2,a1] -> CoreExpr -- Of type tr - -> Coercion -- Of type tr ~ ts + -> CastCoercion -- Of type tr ~ ts -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts -- See Note [Eta reduction with casted arguments] -- for why we have an accumulating coercion @@ -2717,7 +2715,7 @@ tryEtaReduce rec_ids bndrs body eval_sd -- See Note [Eta reduction with casted function] go bs (Cast e co1) co2 - = go bs e (castCoToCo (exprType e) co1 `mkTransCo` co2) + = go bs e (co1 `mkTransCastCo` co2) go bs (Tick t e) co | tickishFloatable t @@ -2740,7 +2738,7 @@ tryEtaReduce rec_ids bndrs body eval_sd , remaining_bndrs `ltLength` bndrs -- Only reply Just if /something/ has happened , ok_fun fun - , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co + , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCastCo co reduced_bndrs = mkVarSet (dropList remaining_bndrs bndrs) -- reduced_bndrs are the ones we are eta-reducing away , used_vars `disjointVarSet` reduced_bndrs @@ -2749,7 +2747,7 @@ tryEtaReduce rec_ids bndrs body eval_sd -- See Note [Eta reduction makes sense], intro and point (1) -- NB: don't compute used_vars from exprFreeVars (mkCast fun co) -- because the latter may be ill formed if the guard fails (#21801) - = Just (mkLams (reverse remaining_bndrs) (mkCast fun co)) + = Just (mkLams (reverse remaining_bndrs) (mkCastCo fun co)) go _remaining_bndrs _fun _ = -- pprTrace "tER fail" (ppr _fun $$ ppr _remaining_bndrs) $ Nothing @@ -2797,10 +2795,10 @@ tryEtaReduce rec_ids bndrs body eval_sd --------------- ok_arg :: Var -- Of type bndr_t -> CoreExpr -- Of type arg_t - -> Coercion -- Of kind (t1~t2) + -> CastCoercion -- Of kind (t1~t2) -> Type -- Type (arg_t -> t1) of the function -- to which the argument is supplied - -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) + -> Maybe (CastCoercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) -- (and similarly for tyvars, coercion args) , [CoreTickish]) -- See Note [Eta reduction with casted arguments] @@ -2808,7 +2806,7 @@ tryEtaReduce rec_ids bndrs body eval_sd | Just tv <- getTyVar_maybe arg_ty , bndr == tv = case splitForAllForAllTyBinder_maybe fun_ty of Just (Bndr _ vis, _) -> Just (fco, []) - where !fco = mkForAllCo tv vis coreTyLamForAllTyFlag MRefl co + where !fco = mkForAllCastCo tv vis coreTyLamForAllTyFlag co -- The lambda we are eta-reducing always has visibility -- 'coreTyLamForAllTyFlag' which may or may not match -- the visibility on the inner function (#24014) @@ -2821,13 +2819,13 @@ tryEtaReduce rec_ids bndrs body eval_sd , let mult = idMult bndr , Just (_af, fun_mult, _, _) <- splitFunTy_maybe fun_ty , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort - = Just (mkFunResCo Representational bndr co, []) + = Just (mkFunResCastCo Representational bndr co, []) ok_arg bndr (Cast e co_arg) co fun_ty | (ticks, Var v) <- stripTicksTop tickishFloatable e - , Just (_, fun_mult, _, _) <- splitFunTy_maybe fun_ty + , Just (_, fun_mult, _, res_ty) <- splitFunTy_maybe fun_ty , bndr == v , fun_mult `eqType` idMult bndr - = Just (mkFunCoNoFTF Representational (multToCo fun_mult) (mkSymCo (castCoToCo (exprType e) co_arg)) co, ticks) + = Just (mkFunCastCoNoFTF Representational fun_mult (castCoercionRKind (exprType e) co_arg) (mkSymCastCo (exprType e) co_arg) res_ty co, ticks) -- TODO check types -- The simplifier combines multiple casts into one, -- so we can have a simple-minded pattern match here ok_arg bndr (Tick t arg) co fun_ty @@ -2873,43 +2871,44 @@ Here we implement the "push rules" from FC papers: by pushing the coercion into the arguments -} -pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion) -pushCoArgs co [] = return ([], MCo co) -pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg - ; case m_co1 of - MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args - ; return (arg':args', m_co2) } - MRefl -> return (arg':args, MRefl) } - -pushMCoArg :: MCoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) -pushMCoArg MRefl arg = Just (arg, MRefl) -pushMCoArg (MCo co) arg = pushCoArg co arg - -pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) +pushCoArgs :: Type -> CastCoercion -> [CoreArg] -> Maybe ([CoreArg], CastCoercion) +pushCoArgs _ co [] = return ([], co) +pushCoArgs fun_ty co (arg:args) = do + { (arg', m_co1) <- pushCoArg fun_ty co arg + ; if isReflCastCo m_co1 + then return (arg':args, ReflCastCo) + else do { (args', m_co2) <- pushCoArgs (funResultTy fun_ty) m_co1 args -- TODO check type + ; return (arg':args', m_co2) } + } + +pushCoArg :: Type -> CastCoercion -> CoreArg -> Maybe (CoreArg, CastCoercion) -- We have (fun |> co) arg, and we want to transform it to -- (fun arg) |> co -- This may fail, e.g. if (fun :: N) where N is a newtype -- C.f. simplCast in GHC.Core.Opt.Simplify -- 'co' is always Representational -pushCoArg co arg +pushCoArg fun_ty co arg | Type ty <- arg - = do { (ty', m_co') <- pushCoTyArg co ty + = do { (ty', m_co') <- pushCastCoTyArg co ty ; return (Type ty', m_co') } | otherwise - = do { (arg_mco, m_co') <- pushCoValArg co - ; let arg_mco' = checkReflexiveMCo arg_mco - -- checkReflexiveMCo: see Note [Check for reflexive casts in eta expansion] + = do { (arg_mco, m_co') <- pushCastCoValArg fun_ty co + ; let arg_mco' = checkReflexiveCastCo (funArgTy fun_ty) arg_mco + -- checkReflexiveCastCo: see Note [Check for reflexive casts in eta expansion] -- The coercion is very often (arg_co -> res_co), but without -- the argument coercion actually being ReflCo - ; return (arg `mkCastMCo` arg_mco', m_co') } + ; return (arg `mkCastCo` arg_mco', m_co') } + +pushCastCoTyArg :: CastCoercion -> Type -> Maybe (Type, CastCoercion) +pushCastCoTyArg (CCoercion co) ty = pushCoTyArg co ty +pushCastCoTyArg ReflCastCo ty = Just (ty, ReflCastCo) +pushCastCoTyArg (ZCoercion fun_ty cos) ty = Nothing -- TODO do better -pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR) +pushCoTyArg :: CoercionR -> Type -> Maybe (Type, CastCoercion) -- We have (fun |> co) @ty -- Push the coercion through to return -- (fun @ty') |> co' -- 'co' is always Representational --- If the returned coercion is Nothing, then it would have been reflexive; --- it's faster not to compute it, though. pushCoTyArg co ty -- The following is inefficient - don't do `eqType` here, the coercion -- optimizer will take care of it. See #14737. @@ -2917,11 +2916,11 @@ pushCoTyArg co ty -- -- = Just (ty, Nothing) | isReflCo co - = Just (ty, MRefl) + = Just (ty, ReflCastCo) | isForAllTy_ty tyL = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $ - Just (ty `mkCastTy` co1, MCo co2) + Just (ty `mkCastTy` co1, CCoercion co2) | otherwise = Nothing @@ -2941,6 +2940,18 @@ pushCoTyArg co ty -- co2 :: ty1[ (ty|>co1)/a1 ] ~R ty2[ ty/a2 ] -- Arg of mkInstCo is always nominal, hence Nominal +pushCastCoValArg :: Type -> CastCoercion -> Maybe (CastCoercion, CastCoercion) +pushCastCoValArg _ ReflCastCo = Just (ReflCastCo, ReflCastCo) +pushCastCoValArg _ (CCoercion co) = pushCoValArg co +pushCastCoValArg tyL (ZCoercion tyR cos) + | isFunTy tyL -- TODO: do we need to check this or can we assume it? + , isFunTy tyR + , typeHasFixedRuntimeRep new_arg_ty + = Just (ZCoercion new_arg_ty cos, ZCoercion (funResultTy tyR) cos) + | otherwise = Nothing + where + new_arg_ty = funArgTy tyR + -- | If @pushCoValArg co = Just (co_arg, co_res)@, then -- -- > (\x.body) |> co = (\y. let { x = y |> co_arg } in body) |> co_res) @@ -2952,7 +2963,7 @@ pushCoTyArg co ty -- If the LHS is well-typed, then so is the RHS. In particular, the argument -- @arg |> co_arg@ is guaranteed to have a fixed 'RuntimeRep', in the sense of -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR) +pushCoValArg :: CoercionR -> Maybe (CastCoercion, CastCoercion) pushCoValArg co -- The following is inefficient - don't do `eqType` here, the coercion -- optimizer will take care of it. See #14737. @@ -2960,7 +2971,7 @@ pushCoValArg co -- -- = Just (mkRepReflCo arg, Nothing) | isReflCo co - = Just (MRefl, MRefl) + = Just (ReflCastCo, ReflCastCo) | isFunTy tyL , (_, co1, co2) <- decomposeFunCo co @@ -2979,8 +2990,8 @@ pushCoValArg co (vcat [ text "co:" <+> ppr co , text "old_arg_ty:" <+> ppr old_arg_ty , text "new_arg_ty:" <+> ppr new_arg_ty ]) $ - Just (coToMCo (mkSymCo co1), coToMCo co2) - -- Critically, coToMCo to checks for ReflCo; the whole coercion may not + Just (coToCastCo (mkSymCo co1), coToCastCo co2) + -- Critically, coToCastCo to checks for ReflCo; the whole coercion may not -- be reflexive, but either of its components might be -- We could use isReflexiveCo, but it's not clear if the benefit -- is worth the cost, and it makes no difference in #18223 @@ -2993,13 +3004,14 @@ pushCoValArg co Pair tyL tyR = coercionKind co pushCoercionIntoLambda - :: HasDebugCallStack => Subst -> InVar -> InExpr -> OutCoercionR -> Maybe (OutVar, OutExpr) + :: HasDebugCallStack => Subst -> InVar -> InExpr -> OutCastCoercion -> Maybe (OutVar, OutExpr) -- This implements the Push rule from the paper on coercions -- (\x. e) |> co -- ===> -- (\x'. e |> co') -pushCoercionIntoLambda subst x e co +pushCoercionIntoLambda subst x e cco | assert (not (isTyVar x) && not (isCoVar x)) True + , CCoercion co <- cco -- AMG TODO: support for other CastCoercions , Pair s1s2 t1t2 <- coercionKind co , Just {} <- splitFunTy_maybe s1s2 , Just (_, w1, t1,_t2) <- splitFunTy_maybe t1t2 @@ -3024,7 +3036,7 @@ pushCoercionIntoLambda subst x e co | otherwise = Nothing -pushCoDataCon :: DataCon -> [CoreExpr] -> MCoercionR +pushCoDataCon :: DataCon -> [CoreExpr] -> CastCoercion -> Maybe (DataCon , [Type] -- Universal type args , [CoreExpr]) -- All other args incl existentials @@ -3034,8 +3046,9 @@ pushCoDataCon :: DataCon -> [CoreExpr] -> MCoercionR -- where co :: (T t1 .. tn) ~ (T s1 .. sn) -- The left-hand one must be a T, because exprIsConApp returned True -- but the right-hand one might not be. (Though it usually will.) -pushCoDataCon dc dc_args MRefl = Just $! (push_dc_refl dc dc_args) -pushCoDataCon dc dc_args (MCo co) = push_dc_gen dc dc_args co (coercionKind co) +pushCoDataCon dc dc_args ReflCastCo = Just $! (push_dc_refl dc dc_args) +pushCoDataCon dc dc_args (CCoercion co) = push_dc_gen dc dc_args co (coercionKind co) +pushCoDataCon dc dc_args (ZCoercion ty cos) = Nothing -- AMG TODO: pushCoDataCon push_dc_refl :: DataCon -> [CoreExpr] -> (DataCon, [Type], [CoreExpr]) push_dc_refl dc dc_args ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -36,7 +36,7 @@ import GHC.Prelude hiding ( head, init, last, tail ) import GHC.Core import GHC.Core.FVs import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, - mkCastMCo, mkTicks ) + mkCastCo, mkTicks ) import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr ) import GHC.Core.Coercion import GHC.Core.Type @@ -2853,7 +2853,7 @@ data OccEnv -- If x :-> (y, co) is in the env, -- then please replace x by (y |> mco) -- Invariant of course: idType x = exprType (y |> mco) - , occ_bs_env :: !(IdEnv (OutId, MCoercion)) + , occ_bs_env :: !(IdEnv (OutId, CastCoercion)) -- Domain is Global and Local Ids -- Range is just Local Ids , occ_bs_rng :: !VarSet @@ -3455,7 +3455,7 @@ addBndrSwap scrut case_bndr -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco) , occ_bs_rng = rng_vars `extendVarSet` case_bndr' - `unionVarSet` tyCoVarsOfMCo mco } + `unionVarSet` tyCoVarsOfCastCo mco } | otherwise = env @@ -3466,7 +3466,7 @@ addBndrSwap scrut case_bndr -- | See bBinderSwaOk. data BinderSwapDecision = NoBinderSwap - | DoBinderSwap OutVar MCoercion + | DoBinderSwap OutVar CastCoercion scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision -- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then @@ -3479,8 +3479,8 @@ scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision scrutOkForBinderSwap e = case e of Tick _ e -> scrutOkForBinderSwap e -- Drop ticks - Var v -> DoBinderSwap v MRefl - Cast (Var v) co -> DoBinderSwap v (MCo (mkSymCo (castCoToCo (idType v) co))) -- TODO: can we do better? + Var v -> DoBinderSwap v ReflCastCo + Cast (Var v) co -> DoBinderSwap v (mkSymCastCo (idType v) co) -- Cast: see Note [Case of cast] _ -> NoBinderSwap @@ -3495,7 +3495,7 @@ lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env }) bndr -- Why do we iterate here? -- See (BS2) in Note [The binder-swap substitution] case lookupBndrSwap env bndr1 of - (fun, fun_id) -> (mkCastMCo fun mco, fun_id) } + (fun, fun_id) -> (mkCastCo fun mco, fun_id) } {- Historical note [Proxy let-bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -19,6 +19,7 @@ import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.ConstantFold import GHC.Core.Type hiding ( substCo, substTy, substTyVar, extendTvSubst, extendCvSubst ) import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCo.Subst ( substCoVarSet ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Inline import GHC.Core.Opt.Simplify.Utils @@ -36,7 +37,7 @@ import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe - , pushCoTyArg, pushCoValArg, exprIsDeadEnd + , pushCastCoTyArg, pushCastCoValArg, exprIsDeadEnd , typeArity, arityTypeArity, etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo {- exprsFreeIds -} ) @@ -54,6 +55,7 @@ import GHC.Types.Unique ( hasKey ) import GHC.Types.Basic import GHC.Types.Tickish import GHC.Types.Var ( isTyCoVar ) +import GHC.Types.Var.Set import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey, seqHashKey ) @@ -644,7 +646,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co) mk_worker_unfolding top_lvl work_id work_rhs = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) - | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo (castCoToCo (exprType rhs) co)) }) + | isStableSource src -> return (unf { uf_tmpl = mkCastCo unf_rhs (mkSymCastCo (exprType rhs) co) }) _ -> mkLetUnfolding env top_lvl VanillaSrc work_id False work_rhs tryCastWorkerWrapper env _ _ bndr rhs -- All other bindings @@ -1361,6 +1363,15 @@ simplCoercion env co subst = getTCvSubst env opts = seOptCoercionOpts env +simplCastCoercion :: SimplEnv -> InType -> InCastCoercion -> SimplM (OutType, OutCastCoercion) +simplCastCoercion env _ (CCoercion co) = (\co -> (coercionLKind co, CCoercion co)) <$> simplCoercion env co +simplCastCoercion env tyL (ZCoercion tyR cos) = (,) <$> simplType env tyL <*> (ZCoercion <$> simplType env tyR <*> simplCoVars env cos) +simplCastCoercion env tyL ReflCastCo = (,) <$> simplType env tyL <*> pure ReflCastCo + +simplCoVars :: SimplEnv -> CoVarSet -> SimplM CoVarSet +simplCoVars env covars = pure $ substCoVarSet (getTCvSubst env) covars + + ----------------------------------- -- | Push a TickIt context outwards past applications and cases, as -- long as this is a non-scoping tick, to let case and application @@ -1531,10 +1542,10 @@ rebuild_go env expr cont Stop {} -> return (emptyFloats env, expr) TickIt t cont -> rebuild_go env (mkTick t expr) cont CastIt { sc_co = co, sc_opt = opt, sc_cont = cont } - -> rebuild_go env (mkCast expr co') cont + -> rebuild_go env (mkCastCo expr co') cont -- NB: mkCast implements the (Coercion co |> g) optimisation where - co' = optOutCoercion env co opt + co' = optOutCastCoercion env co opt Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont @@ -1663,6 +1674,12 @@ on each successive composition -- that's at least quadratic. So: -} +optOutCastCoercion :: SimplEnvIS -> OutCastCoercion -> Bool -> OutCastCoercion +optOutCastCoercion env cco already_optimised = case cco of + ReflCastCo -> ReflCastCo + CCoercion co -> CCoercion (optOutCoercion env co already_optimised) + ZCoercion{} -> cco + optOutCoercion :: SimplEnvIS -> OutCoercion -> Bool -> OutCoercion -- See Note [Avoid re-simplifying coercions] optOutCoercion env co already_optimised @@ -1675,72 +1692,74 @@ optOutCoercion env co already_optimised simplCast :: SimplEnv -> InExpr -> InCastCoercion -> SimplCont -> SimplM (SimplFloats, OutExpr) simplCast env body co0 cont0 - = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env (castCoToCo (exprType body) co0) -- TODO better way? + = do { (tyL, co1) <- {-#SCC "simplCast-simplCoercion" #-} simplCastCoercion env (exprType body) co0 ; cont1 <- {-#SCC "simplCast-addCoerce" #-} - if isReflCo co1 + if isReflCastCo co1 then return cont0 -- See Note [Optimising reflexivity] - else addCoerce co1 True cont0 + else addCoerce tyL co1 True cont0 -- True <=> co1 is optimised ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } where -- If the first parameter is MRefl, then simplifying revealed a -- reflexive coercion. Omit. - addCoerceM :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont - addCoerceM MRefl _ cont = return cont - addCoerceM (MCo co) opt cont = addCoerce co opt cont - - addCoerce :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont - addCoerce co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity] - = addCoerce (mkTransCo co1 co2) False cont + -- TODO: probably can simplify this further now? + addCoerceM :: OutType -> OutCastCoercion -> Bool -> SimplCont -> SimplM SimplCont + addCoerceM _ ReflCastCo _ cont = return cont + addCoerceM tyL co opt cont = addCoerce tyL co opt cont + + -- Type tyL is the coercionLKind of the coercion + addCoerce :: OutType -> OutCastCoercion -> Bool -> SimplCont -> SimplM SimplCont + addCoerce tyL co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity] + = addCoerce tyL (mkTransCastCo co1 co2) False cont -- False: (mkTransCo co1 co2) is not fully optimised -- See Note [Avoid re-simplifying coercions] - addCoerce co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) - | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty + addCoerce tyL co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = tail }) + | Just (arg_ty', m_co') <- pushCastCoTyArg co arg_ty = {-#SCC "addCoerce-pushCoTyArg" #-} - do { tail' <- addCoerceM m_co' co_is_opt tail + do { tail' <- addCoerceM hole_ty m_co' co_is_opt tail -- TODO is hole_ty right? ; return (ApplyToTy { sc_arg_ty = arg_ty' , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } + , sc_hole_ty = tyL }) } -- NB! As the cast goes past, the -- type of the hole changes (#16312) -- (f |> co) e ===> (f (e |> co1)) |> co2 -- where co :: (s1->s2) ~ (t1->t2) -- co1 :: t1 ~ s1 -- co2 :: s2 ~ t2 - addCoerce co co_is_opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se + addCoerce tyL co co_is_opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_dup = dup, sc_cont = tail , sc_hole_ty = fun_ty }) | not co_is_opt -- pushCoValArg duplicates the coercion, so optimise first - = addCoerce (optOutCoercion (zapSubstEnv env) co co_is_opt) True cont + = addCoerce tyL (optOutCastCoercion (zapSubstEnv env) co co_is_opt) True cont - | Just (m_co1, m_co2) <- pushCoValArg co + | Just (m_co1, m_co2) <- pushCastCoValArg fun_ty co -- TODO check fun_ty = {-#SCC "addCoerce-pushCoValArg" #-} - do { tail' <- addCoerceM m_co2 co_is_opt tail - ; case m_co1 of { - MRefl -> return (cont { sc_cont = tail' - , sc_hole_ty = coercionLKind co }) ; + do { tail' <- addCoerceM (funResultTy fun_ty) m_co2 co_is_opt tail -- TODO check funResultTy fun_ty + ; if isReflCastCo m_co1 + then return (cont { sc_cont = tail' + , sc_hole_ty = tyL }) ; -- See Note [Avoiding simplifying repeatedly] - MCo co1 -> + else do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing arg_se arg -- When we build the ApplyTo we can't mix the OutCoercion -- 'co' with the InExpr 'arg', so we simplify -- to make it all consistent. It's a bit messy. -- But it isn't a common case. -- Example of use: #995 - ; return (ApplyToVal { sc_arg = mkCast arg' co1 + ; return (ApplyToVal { sc_arg = mkCastCo arg' m_co1 , sc_env = arg_se' , sc_dup = dup' , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } } } + , sc_hole_ty = tyL }) } } - addCoerce co co_is_opt cont - | isReflCo co = return cont -- Having this at the end makes a huge + addCoerce tyL co co_is_opt cont + | isReflCastCo co = return cont -- Having this at the end makes a huge -- difference in T12227, for some reason -- See Note [Optimising reflexivity] - | otherwise = return (CastIt { sc_co = co, sc_opt = co_is_opt, sc_cont = cont }) + | otherwise = return (CastIt { sc_co = co, sc_hole_ty = tyL, sc_opt = co_is_opt, sc_cont = cont }) simplLazyArg :: SimplEnvIS -- ^ Used only for its InScopeSet -> DupFlag @@ -3595,9 +3614,9 @@ addAltUnfoldings env case_bndr bndr_swap con_app -- See Note [Add unfolding for scrutinee] env2 | DoBinderSwap v mco <- bndr_swap = addBinderUnfolding env1 v $ - if isReflMCo mco -- isReflMCo: avoid calling mk_simple_unf + if isReflCastCo mco -- isReflCastCo: avoid calling mk_simple_unf then con_app_unf -- twice in the common case - else mk_simple_unf (mkCastMCo con_app mco) + else mk_simple_unf (mkCastCo con_app mco) | otherwise = env1 @@ -3865,9 +3884,10 @@ mkDupableContWithDmds env _ cont mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn -mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }) +mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_hole_ty = ty, sc_opt = opt, sc_cont = cont }) = do { (floats, cont') <- mkDupableContWithDmds env dmds cont - ; return (floats, CastIt { sc_co = optOutCoercion env co opt + ; return (floats, CastIt { sc_co = optOutCastCoercion env co opt + , sc_hole_ty = ty , sc_opt = True, sc_cont = cont' }) } -- optOutCoercion: see Note [Avoid re-simplifying coercions] ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -52,7 +52,7 @@ import GHC.Core.Opt.Simplify.Inline( smallEnoughToInline ) import GHC.Core.Opt.Stats ( Tick(..) ) import qualified GHC.Core.Subst import GHC.Core.Ppr -import GHC.Core.TyCo.Ppr ( pprParendType ) +import GHC.Core.TyCo.Ppr ( pprParendType, pprCastCo ) import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Opt.Arity @@ -162,8 +162,9 @@ data SimplCont | CastIt -- (CastIt co K)[e] = K[ e `cast` co ] - { sc_co :: OutCoercion -- The coercion simplified + { sc_co :: OutCastCoercion -- The coercion simplified -- Invariant: never an identity coercion + , sc_hole_ty :: OutType -- LHS kind of sc_co , sc_opt :: Bool -- True <=> sc_co has had optCoercion applied to it -- See Note [Avoid re-simplifying coercions] -- in GHC.Core.Opt.Simplify.Iteration @@ -277,7 +278,7 @@ instance Outputable SimplCont where where pps = [ppr interesting] ++ [ppr eval_sd | eval_sd /= topSubDmd] ppr (CastIt { sc_co = co, sc_cont = cont }) - = (text "CastIt" <+> pprOptCo co) $$ ppr cont + = (text "CastIt" <+> pprCastCo co) $$ ppr cont ppr (TickIt t cont) = (text "TickIt" <+> ppr t) $$ ppr cont ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) @@ -474,7 +475,7 @@ contResultType (TickIt _ k) = contResultType k contHoleType :: SimplCont -> OutType contHoleType (Stop ty _ _) = ty contHoleType (TickIt _ k) = contHoleType k -contHoleType (CastIt { sc_co = co }) = coercionLKind co +contHoleType (CastIt { sc_hole_ty = ty }) = ty contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se }) = perhapsSubstTy dup se (idType b) contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty @@ -1896,7 +1897,7 @@ rebuildLam env bndrs@(bndr:_) body cont | -- Note [Casts and lambdas] seCastSwizzle env , not (any bad bndrs) - = mkCast (mk_lams bndrs body) (mkPiCos Representational bndrs (castCoToCo (exprType body) co)) + = mkCastCo (mk_lams bndrs body) (mkPiCastCos Representational bndrs co) where co_vars = tyCoVarsOfCastCo co bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -1120,7 +1120,7 @@ extendCaseBndrs env scrut case_bndr con alt_bndrs where live_case_bndr = not (isDeadBinder case_bndr) env1 | DoBinderSwap v mco <- scrutOkForBinderSwap scrut - , isReflMCo mco = extendValEnv env v cval + , isReflCastCo mco = extendValEnv env v cval | otherwise = env -- See Note [Add scrutinee to ValueEnv too] env2 | live_case_bndr = extendValEnv env1 case_bndr cval | otherwise = env1 ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -52,13 +52,14 @@ import GHC.Core.FVs ( exprFreeVars, bindFreeVars , rulesFreeVarsDSet, orphNamesOfExprs ) import GHC.Core.Utils ( exprType, mkTick, mkTicks , stripTicksTopT, stripTicksTopE - , isJoinBind, mkCastMCo ) + , isJoinBind, mkCastCo ) import GHC.Core.Ppr ( pprRules ) import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Core.Type as Type ( Type, extendTvSubst, extendCvSubst , substTy, getTyVar_maybe ) import GHC.Core.TyCo.Ppr( pprParendType ) +import GHC.Core.TyCo.FVs ( tyCoFVsOfCastCoercion ) import GHC.Core.Coercion as Coercion import GHC.Core.Tidy ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr ) @@ -815,7 +816,7 @@ match_exprs :: HasDebugCallStack match_exprs _ subst [] _ = Just subst match_exprs renv subst (e1:es1) (e2:es2) - = do { subst' <- match renv subst e1 e2 MRefl + = do { subst' <- match renv subst e1 e2 ReflCastCo ; match_exprs renv subst' es1 es2 } match_exprs _ _ _ _ = Nothing @@ -1065,7 +1066,7 @@ match :: HasDebugCallStack -> RuleSubst -- Substitution applies to template only -> CoreExpr -- Template -> CoreExpr -- Target - -> MCoercion + -> CastCoercion -> Maybe RuleSubst -- Postcondition (TypeInv): if matching succeeds, then @@ -1102,8 +1103,8 @@ match renv subst (Type ty1) (Type ty2) _mco ------------------------ Coercions --------------------- -- See Note [Coercion arguments] for why this isn't really right -match renv subst (Coercion co1) (Coercion co2) MRefl - = match_co renv subst co1 co2 +match renv subst (Coercion co1) (Coercion co2) ReflCastCo + = match_co renv subst (CCoercion co1) (CCoercion co2) -- TODO should probably have match_cast_co and match_co separately? -- The MCo case corresponds to matching co ~ (co2 |> co3) -- and I have no idea what to do there -- or even if it can occur -- Failing seems the simplest thing to do; it's certainly safe. @@ -1114,23 +1115,23 @@ match renv subst (Coercion co1) (Coercion co2) MRefl -- Note [Cancel reflexive casts] match renv subst e1 (Cast e2 co2) mco - = match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoR (castCoToCo (exprType e2) co2) mco)) + = match renv subst e1 e2 (checkReflexiveCastCo (exprType e2) (mkTransCastCo co2 mco)) -- checkReflexiveMCo: cancel casts if possible -- This is important: see Note [Cancel reflexive casts] match renv subst (Cast e1 co1) e2 mco - = matchTemplateCast renv subst e1 (castCoToCo (exprType e1) co1) e2 mco + = matchTemplateCast renv subst e1 co1 e2 mco ------------------------ Literals --------------------- match _ subst (Lit lit1) (Lit lit2) mco | lit1 == lit2 - = assertPpr (isReflMCo mco) (ppr mco) $ + = assertPpr (isReflCastCo mco) (ppr mco) $ Just subst ------------------------ Variables --------------------- -- The Var case follows closely what happens in GHC.Core.Unify.match match renv subst (Var v1) e2 mco - = match_var renv subst v1 (mkCastMCo e2 mco) + = match_var renv subst v1 (mkCastCo e2 mco) match renv subst e1 (Var v2) mco -- Note [Expanding variables] | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] @@ -1148,7 +1149,7 @@ match renv subst e1 (Var v2) mco -- Note [Expanding variables] -- See Note [Matching higher order patterns] match renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env }) subst e1@App{} e2 - MRefl -- Like the App case we insist on Refl here + ReflCastCo -- Like the App case we insist on Refl here -- See Note [Casts in the target] | (Var f, args) <- collectArgs e1 , let f' = rnOccL rn_env f -- See similar rnOccL in match_var @@ -1308,9 +1309,9 @@ Two wrinkles: -- (e1 e2) ~ (d1 d2) |> co -- See Note [Cancel reflexive casts]: in the Cast equations for 'match' -- we aggressively ensure that if MCo is reflective, it really is MRefl. -match renv subst (App f1 a1) (App f2 a2) MRefl - = do { subst' <- match renv subst f1 f2 MRefl - ; match renv subst' a1 a2 MRefl } +match renv subst (App f1 a1) (App f2 a2) ReflCastCo + = do { subst' <- match renv subst f1 f2 ReflCastCo + ; match renv subst' a1 a2 ReflCastCo } ------------------------ Float lets --------------------- match renv subst e1 (Let bind e2) mco @@ -1336,7 +1337,7 @@ match renv subst e1 (Let bind e2) mco ------------------------ Lambdas --------------------- match renv subst (Lam x1 e1) e2 mco - | let casted_e2 = mkCastMCo e2 mco + | let casted_e2 = mkCastCo e2 mco in_scope = extendInScopeSetSet (rnInScopeSet (rv_lcl renv)) (exprFreeVars casted_e2) in_scope_env = ISE in_scope (rv_unf renv) @@ -1349,7 +1350,7 @@ match renv subst (Lam x1 e1) e2 mco -- See Note [Lambdas in the template] = let renv' = rnMatchBndr2 renv x1 x2 subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } - in match renv' subst' e1 e2' MRefl + in match renv' subst' e1 e2' ReflCastCo match renv subst e1 e2@(Lam {}) mco | Just (renv', e2') <- eta_reduce renv e2 -- See Note [Eta reduction in the target] @@ -1400,7 +1401,7 @@ match renv (tv_subst, id_subst, binds) e1 match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) mco = do { subst1 <- match_ty renv subst ty1 ty2 - ; subst2 <- match renv subst1 e1 e2 MRefl + ; subst2 <- match renv subst1 e1 e2 ReflCastCo ; let renv' = rnMatchBndr2 renv x1 x2 ; match_alts renv' subst2 alts1 alts2 mco -- Alts are both sorted } @@ -1503,29 +1504,29 @@ Hence ------------- matchTemplateCast :: RuleMatchEnv -> RuleSubst - -> CoreExpr -> Coercion - -> CoreExpr -> MCoercion + -> CoreExpr -> CastCoercion + -> CoreExpr -> CastCoercion -> Maybe RuleSubst matchTemplateCast renv subst e1 co1 e2 mco | isEmptyVarSet $ fvVarSet $ filterFV (`elemVarSet` rv_tmpls renv) $ -- Check that the coercion does not - tyCoFVsOfCo substed_co -- mention any of the template variables + tyCoFVsOfCastCoercion substed_co -- mention any of the template variables = -- This is the good path -- See Note [Casts in the template] wrinkle (CT0) - match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoL mco (mkSymCo substed_co))) + match renv subst e1 e2 (checkReflexiveCastCo substed_ty (mkTransCastCo mco (mkSymCastCo substed_ty substed_co))) + -- AMG TODO: should be able to make checkReflexiveCastCo cheaper here? | otherwise = -- This is the Deeply Suspicious Path -- See Note [Casts in the template] - do { let co2 = case mco of - MRefl -> mkRepReflCo (exprType e2) - MCo co2 -> co2 + do { let co2 = mco ; subst1 <- match_co renv subst co1 co2 -- If match_co succeeds, then (exprType e1) = (exprType e2) - -- Hence the MRefl in the next line - ; match renv subst1 e1 e2 MRefl } + -- Hence the ReflCastCo in the next line + ; match renv subst1 e1 e2 ReflCastCo } where - substed_co = substCo current_subst co1 + substed_ty = substTy current_subst (exprType e1) + substed_co = substCastCo current_subst co1 current_subst :: Subst current_subst = mkTCvSubst (rnInScopeSet (rv_lcl renv)) @@ -1538,8 +1539,8 @@ matchTemplateCast renv subst e1 co1 e2 mco match_co :: RuleMatchEnv -> RuleSubst - -> Coercion - -> Coercion + -> CastCoercion + -> CastCoercion -> Maybe RuleSubst -- We only match if the template is a coercion variable or Refl: -- see Note [Casts in the template] @@ -1548,7 +1549,7 @@ match_co :: RuleMatchEnv -- But if match_co succeeds, it /is/ guaranteed that -- coercionKind (subst template) = coercionKind target -match_co renv subst co1 co2 +match_co renv subst (CCoercion co1) (CCoercion co2) | Just cv <- getCoVar_maybe co1 = match_var renv subst cv (Coercion co2) @@ -1563,6 +1564,7 @@ match_co renv subst co1 co2 | otherwise = Nothing +match_co renv subst _ _ = Nothing -- TODO: support non-CCoercions in rule matcher ------------- rnMatchBndr2 :: RuleMatchEnv -> Var -> Var -> RuleMatchEnv @@ -1575,7 +1577,7 @@ rnMatchBndr2 renv x1 x2 match_alts :: RuleMatchEnv -> RuleSubst -> [CoreAlt] -- Template - -> [CoreAlt] -> MCoercion -- Target + -> [CoreAlt] -> CastCoercion -- Target -> Maybe RuleSubst match_alts _ subst [] [] _ = return subst @@ -2018,7 +2020,7 @@ ruleAppCheck_help env fn args rules mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, not (isJust (match_fn rule_arg arg))] - match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl + match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg ReflCastCo where renv = RV { rv_lcl = mkRnEnv2 in_scope , rv_tmpls = mkVarSet rule_bndrs ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -31,8 +31,8 @@ import GHC.Core.Unfold.Make import GHC.Core.Make ( FloatBind(..), mkWildValBinder ) import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) import GHC.Core.DataCon -import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) ) -import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList +import GHC.Core.Coercion.Opt ( optCoercion, optCastCoercion, OptCoercionOpts (..) ) +import GHC.Core.Type hiding ( extendTvSubst, extendCvSubst, extendTvSubstList , isInScope, substTyVarBndr, cloneTyVarBndr ) import GHC.Core.Predicate( isCoVarType ) import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) @@ -213,7 +213,7 @@ simpleOptPgm opts this_mod binds rules = ---------------------- type SimpleClo = (SimpleOptEnv, InExpr) -data SimpleContItem = ApplyToArg SimpleClo | CastIt OutCoercion +data SimpleContItem = ApplyToArg SimpleClo | CastIt OutCastCoercion instance Outputable SimpleContItem where ppr (ApplyToArg (_, arg)) = text "ARG" <+> ppr arg @@ -402,7 +402,7 @@ simple_app env e0@(Lam {}) as0@(_:_) = rebuild_app env (simple_opt_expr env e) as do_beta env (Cast e co) as = - do_beta env e (add_cast env (castCoToCo (exprType e) co) as) -- TODO eliminate castCoToCo? + do_beta env e (add_cast env (exprType e) co as) do_beta env body as = simple_app env body as @@ -450,21 +450,21 @@ simple_app env (Let bind body) args expr' = Let bind' (simple_opt_expr env' body) simple_app env (Cast e co) as - = simple_app env e (add_cast env (castCoToCo (exprType e) co) as) -- TODO eliminate castCoToCo? + = simple_app env e (add_cast env (exprType e) co as) simple_app env e as = rebuild_app env (simple_opt_expr env e) as -add_cast :: SimpleOptEnv -> InCoercion -> [SimpleContItem] -> [SimpleContItem] -add_cast env co1 as - | isReflCo co1' +add_cast :: SimpleOptEnv -> InType -> InCastCoercion -> [SimpleContItem] -> [SimpleContItem] +add_cast env tyL co1 as + | isReflCastCo co1' = as | otherwise = case as of - CastIt co2:rest -> CastIt (co1' `mkTransCo` co2):rest + CastIt co2:rest -> CastIt (co1' `mkTransCastCo` co2):rest _ -> CastIt co1':as where - co1' = optCoercion (so_co_opts (soe_opts env)) (soe_subst env) co1 + co1' = optCastCoercion (so_co_opts (soe_opts env)) (soe_subst env) tyL co1 rebuild_app :: HasDebugCallStack => SimpleOptEnv -> OutExpr -> [SimpleContItem] -> OutExpr @@ -473,7 +473,7 @@ rebuild_app env fun args = foldl mk_app fun args in_scope = soeInScope env mk_app out_fun = \case ApplyToArg arg -> App out_fun (simple_opt_clo in_scope arg) - CastIt co -> mk_cast out_fun (CCoercion co) + CastIt co -> mk_cast out_fun co {- Note [Desugaring unlifted newtypes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1340,7 +1340,7 @@ data-con wrappers, and that cure would be worse than the disease. This Note exists solely to document the problem. -} -data ConCont = CC [CoreExpr] MCoercion +data ConCont = CC [CoreExpr] CastCoercion -- Substitution already applied -- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument @@ -1362,7 +1362,7 @@ exprIsConApp_maybe :: HasDebugCallStack => InScopeEnv -> CoreExpr -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) exprIsConApp_maybe ise@(ISE in_scope id_unf) expr - = go (Left in_scope) [] expr (CC [] MRefl) + = go (Left in_scope) [] expr (CC [] ReflCastCo) where go :: Either InScopeSet Subst -- Left in-scope means "empty substitution" @@ -1375,10 +1375,10 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr go subst floats (Tick t expr) cont | not (tickishIsCode t) = go subst floats expr cont - go subst floats (Cast expr co1) (CC args m_co2) - | Just (args', m_co1') <- pushCoArgs (subst_co subst (castCoToCo (exprType expr) co1)) args + go subst floats (Cast expr co1) (CC args m_co2) -- TODO: is the subst_ty below needed? + | Just (args', m_co1') <- pushCoArgs (subst_ty subst (exprType expr)) (subst_cast_co subst co1) args -- See Note [Push coercions in exprIsConApp_maybe] - = go subst floats expr (CC args' (m_co1' `mkTransMCo` m_co2)) + = go subst floats expr (CC args' (m_co1' `mkTransCastCo` m_co2)) go subst floats (App fun arg) (CC args mco) | let arg_type = exprType arg @@ -1515,6 +1515,12 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr subst_co (Left {}) co = co subst_co (Right s) co = GHC.Core.Subst.substCo s co + subst_cast_co (Left {}) co = co + subst_cast_co (Right s) co = substCastCo s co + + subst_ty (Left {}) ty = ty + subst_ty (Right s) ty = substTy s ty + subst_expr (Left {}) e = e subst_expr (Right s) e = substExpr s e @@ -1565,7 +1571,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr (right, _, _) -> pprPanic "case_bind did not preserve Left" (ppr in_scope $$ ppr arg $$ ppr right) -- See Note [exprIsConApp_maybe on literal strings] -dealWithStringLiteral :: Var -> BS.ByteString -> MCoercion +dealWithStringLiteral :: Var -> BS.ByteString -> CastCoercion -> Maybe (DataCon, [Type], [CoreExpr]) -- This is not possible with user-supplied empty literals, GHC.Core.Make.mkStringExprFS @@ -1666,13 +1672,12 @@ exprIsLambda_maybe ise (Tick t e) = Just (x, e, t:ts) -- Also possible: A casted lambda. Push the coercion inside -exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e cco) +exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co) | Just (x, e,ts) <- exprIsLambda_maybe ise casted_e -- Only do value lambdas. -- this implies that x is not in scope in gamma (makes this code simpler) , not (isTyVar x) && not (isCoVar x) - , let co = castCoToCo (exprType casted_e) cco - , assert (not $ x `elemVarSet` tyCoVarsOfCo co) True + , assert (not $ x `elemVarSet` tyCoVarsOfCastCo co) True , Just (x',e') <- pushCoercionIntoLambda (mkEmptySubst in_scope_set) x e co , let res = Just (x',e',ts) = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) ===================================== compiler/GHC/Core/TyCo/FVs.hs ===================================== @@ -21,7 +21,7 @@ module GHC.Core.TyCo.FVs shallowCoVarsOfCo, shallowCoVarsOfCos, shallowCoVarsOfCastCo, tyCoVarsOfCastCoercionDSet, tyCoVarsOfCoDSet, - tyCoFVsOfCo, tyCoFVsOfCos, tyCoFVsOfCoVarSet, + tyCoFVsOfCo, tyCoFVsOfCos, tyCoFVsOfCoVarSet, tyCoFVsOfCastCoercion, tyCoVarsOfCoList, coVarsOfCoDSet, coVarsOfCosDSet, ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -22,7 +22,7 @@ module GHC.Core.Utils ( -- * Properties of expressions exprType, coreAltType, coreAltsType, - mkLamType, mkLamTypes, + mkLamType, mkLamTypes, mkPiMCos, mkFunctionType, exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe, trivial_expr_fold, @@ -188,6 +188,12 @@ mkLamType v body_ty mkLamTypes vs ty = foldr mkLamType ty vs +mkPiMCos :: [Var] -> CastCoercion -> CastCoercion +mkPiMCos _ ReflCastCo = ReflCastCo +mkPiMCos vs (CCoercion co) = CCoercion (mkPiCos Representational vs co) +mkPiMCos vs (ZCoercion ty cos) = ZCoercion (mkLamTypes vs ty) cos + + {- Note [Type bindings] ~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/43867efa0709ccca1e1577d85e8088… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/43867efa0709ccca1e1577d85e8088… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26607] Wibble
by Simon Peyton Jones (＠simonpj) 25 Nov '25

25 Nov '25

Simon Peyton Jones pushed to branch wip/T26607 at Glasgow Haskell Compiler / GHC Commits: 8ddc0d55 by Simon Peyton Jones at 2025-11-25T00:29:07+00:00 Wibble - - - - - 1 changed file: - compiler/GHC/Stg/Lint.hs Changes: ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -109,7 +109,7 @@ import GHC.Core.Lint ( lintMessage ) import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel, isMarkedCbv ) import GHC.Types.CostCentre ( isCurrentCCS ) import GHC.Types.Id -import GHC.Types.Literal ( isLitRubbish ) +import GHC.Types.Literal ( Literal, isLitRubbish ) import GHC.Types.Var.Set import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom ) import GHC.Types.RepType @@ -186,7 +186,7 @@ lintStgConArg arg = do text "Its PrimReps are: " <> ppr badRep case arg of - StgLitArg _ -> pure () + StgLitArg l -> lintStgLit l StgVarArg v -> lintStgVar v lintStgFunArg :: StgArg -> LintM () @@ -201,7 +201,7 @@ lintStgFunArg arg = do text "Its PrimReps are: " <> ppr badRep case arg of - StgLitArg _ -> pure () + StgLitArg l -> lintStgLit l StgVarArg v -> lintStgVar v lintStgVar :: Id -> LintM () @@ -275,9 +275,7 @@ lintStgRhs rhs@(StgRhsCon _ con _ _ args _) = do lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM () -lintStgExpr (StgLit lit) - | isLitRubbish lit = addErrL (hang (text "Found rubbish literal:") 2 (ppr lit)) - | otherwise = return () +lintStgExpr (StgLit lit) = lintStgLit lit lintStgExpr e@(StgApp fun args) = do lintStgVar fun @@ -285,8 +283,6 @@ lintStgExpr e@(StgApp fun args) = do lintAppCbvMarks e lintStgAppReps fun args - - lintStgExpr app@(StgConApp con _n args _arg_tys) = do -- unboxed sums should vanish during unarise lf <- getLintFlags @@ -324,6 +320,11 @@ lintStgExpr (StgCase scrut bndr alts_type alts) = do addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts) +lintStgLit :: Literal -> LintM () +lintStgLit lit + | isLitRubbish lit = addErrL (hang (text "Found rubbish literal:") 2 (ppr lit)) + | otherwise = return () + lintAlt :: (OutputablePass a, BinderP a ~ Id) => GenStgAlt a -> LintM () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8ddc0d55449b004c11656c089a4dcd3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8ddc0d55449b004c11656c089a4dcd3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] - look through applications to check if we need deepsubsumption
by Apoorv Ingle (＠ani) 24 Nov '25

24 Nov '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 1a3afd5c by Apoorv Ingle at 2025-11-24T15:50:29-06:00 - look through applications to check if we need deepsubsumption - Tests cleanup - - - - - 20 changed files: - compiler/GHC/CmmToAsm.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Hs.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Utils/Monad.hs - − testsuite/tests/deSugar/should_compile/T10662 - − testsuite/tests/ghci.debugger/Do - − testsuite/tests/ghci.debugger/Do.hs - − testsuite/tests/ghci.debugger/T25996.hs - + testsuite/tests/typecheck/should_compile/ExpansionQLIm.hs - − testsuite/tests/typecheck/should_compile/T25996.hs - testsuite/tests/typecheck/should_compile/all.T - − testsuite/tests/typecheck/should_fail/T25970.hs - − testsuite/tests/typecheck/should_fail/T25996.hs - testsuite/tests/typecheck/should_fail/T7857.stderr - testsuite/tests/typecheck/should_fail/tcfail181.stderr Changes: ===================================== compiler/GHC/CmmToAsm.hs ===================================== @@ -1,4 +1,3 @@ -{-# LANGUAGE DeepSubsumption #-} -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 1993-2004 ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -8,7 +8,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DeepSubsumption #-} module GHC.Driver.Downsweep ( downsweep , downsweepThunk ===================================== compiler/GHC/Hs.hs ===================================== @@ -36,8 +36,7 @@ module GHC.Hs ( module GHC.Parser.Annotation, HsModule(..), AnnsModule(..), - HsParsedModule(..), XModulePs(..), - + HsParsedModule(..), XModulePs(..) ) where -- friends: ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1157,7 +1157,8 @@ the typechecker: * HsDo, where we give the SrcSpan of the entire do block to each ApplicativeStmt. * Expanded (via ExpandedThingRn) ExplicitList{}, where we give the SrcSpan of the original - list expression to the 'fromListN' call. + list expression to the expanded expression. The 'fromListN' is assigned + a generated location span In order for the implicit function calls to not be confused for actual occurrences of functions in the source code, most of this extra information ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -8,7 +8,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeepSubsumption #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage {-# LANGUAGE InstanceSigs #-} ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -53,6 +53,7 @@ import GHC.Builtin.PrimOps( tagToEnumKey ) import GHC.Builtin.Names import GHC.Types.Var +import GHC.Types.Id ( isDataConId ) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Reader @@ -186,15 +187,14 @@ Note [Instantiation variables are short lived] tcExprSigma :: Bool -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) tcExprSigma inst rn_expr = do { (fun@(rn_fun,fun_lspan), rn_args) <- splitHsApps rn_expr - -- ; ds_flag <- getDeepSubsumptionFlag_DataConHead rn_fun - -- ; do_ql <- wantQuickLook rn_fun ; (tc_fun, fun_sigma) <- tcInferAppHead fun ; code_orig <- getSrcCodeOrigin ; let fun_orig | not (isGeneratedSrcSpan fun_lspan) = exprCtOrigin rn_fun | otherwise = srcCodeOriginCtOrigin rn_fun code_orig - ; traceTc "tcExprSigma" (vcat [text "rn_expr:" <+> ppr rn_expr, ppr tc_fun]) + ; traceTc "tcExprSigma" (vcat [ text "rn_expr:" <+> ppr rn_expr + , text "tc_fun" <+> ppr tc_fun ]) ; (inst_args, app_res_sigma) <- tcInstFun DoQL inst (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_args ; tc_args <- tcValArgs DoQL (rn_fun, fun_lspan) inst_args ; let tc_expr = rebuildHsApps (tc_fun, fun_lspan) tc_args @@ -486,11 +486,31 @@ getDeepSubsumptionFlag_DataConHead app_head = ; return $ if | user_ds -> Deep DeepSub - | XExpr (ConLikeTc (RealDataCon {})) <- app_head - -> Deep TopSub | otherwise - -> Shallow - } + -> go app_head + } + where + go :: HsExpr GhcTc -> DeepSubsumptionFlag + go app_head + | XExpr (ConLikeTc (RealDataCon {})) <- app_head + = Deep TopSub + | XExpr (ExpandedThingTc _ f) <- app_head + = go f + | XExpr (WrapExpr _ f) <- app_head + = go f + | HsVar _ f <- app_head + , isDataConId (unLoc f) + = Deep TopSub + | HsApp _ f _ <- app_head + = go (unLoc f) + | HsAppType _ f _ <- app_head + = go (unLoc f) + | OpApp _ _ f _ <- app_head + = go (unLoc f) + | HsPar _ f <- app_head + = go (unLoc f) + | otherwise + = Shallow finishApp :: (HsExpr GhcTc, SrcSpan) -> [HsExprArg 'TcpTc] -> TcRhoType -> HsWrapper ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -767,6 +767,8 @@ tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty) tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcXExpr (ExpandedThingRn o e) res_ty = mkExpandedTc o <$> -- necessary for hpc ticks + -- Need to call tcExpr and not tcApp + -- as e can be let statements which tcApp cannot gracefully handle tcExpr e res_ty -- For record selection, same as HsVar case ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -465,9 +465,11 @@ tcInferAppHead_maybe fun = case fun of HsVar _ nm -> Just <$> tcInferId nm XExpr (HsRecSelRn f) -> Just <$> tcInferRecSelId f - XExpr (ExpandedThingRn o e) -> Just <$> (addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) $ -- ANI: TODO this is fishy.. - -- We do not want to instantiate c.f. T19167 - tcExprSigma False e + XExpr (ExpandedThingRn o e) -> Just <$> (addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) $ + -- ANI: TODO this is addExpansionErrCtxt is fishy.. + -- We do not want to instantiate the type of the head + -- c.f. T19167 + (\ (x, y) -> (mkExpandedTc o x, y)) <$> tcExprSigma False e ) ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty HsOverLit _ lit -> Just <$> tcInferOverLit lit ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -63,7 +63,7 @@ module GHC.Tc.Utils.Monad( -- * Error management getSrcCodeOrigin, getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, - inGeneratedCode, -- setInGeneratedCode, + inGeneratedCode, wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, wrapLocMA_,wrapLocMA, getErrsVar, setErrsVar, ===================================== testsuite/tests/deSugar/should_compile/T10662 deleted ===================================== Binary files a/testsuite/tests/deSugar/should_compile/T10662 and /dev/null differ ===================================== testsuite/tests/ghci.debugger/Do deleted ===================================== Binary files a/testsuite/tests/ghci.debugger/Do and /dev/null differ ===================================== testsuite/tests/ghci.debugger/Do.hs deleted ===================================== @@ -1,6 +0,0 @@ - -module Main where - -main :: IO () -main = do putStrLn "Hello" - putStrLn "World" ===================================== testsuite/tests/ghci.debugger/T25996.hs deleted ===================================== @@ -1,17 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Wno-unused-local-binds #-} -{-# OPTIONS_GHC -Wno-unused-top-binds #-} - -main :: IO () -main = do - pure () - where - biz :: IO () - biz = do - pure (10 :: Integer) - pure () - -biz' :: IO () -biz' = do - pure (10 :: Integer) - pure () ===================================== testsuite/tests/typecheck/should_compile/ExpansionQLIm.hs ===================================== @@ -0,0 +1,10 @@ +module Test where + + +qqqq :: [String] +qqqq = (show (1 :: Int) :) $ ["2"] + +main :: IO () +main = do + putStrLn "abc" + putStrLn $ concat qqqq ===================================== testsuite/tests/typecheck/should_compile/T25996.hs deleted ===================================== @@ -1,20 +0,0 @@ - -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Wno-unused-local-binds #-} -{-# OPTIONS_GHC -Wno-unused-top-binds #-} - -module T25996 where - -main :: IO () -main = do - pure () - where - biz :: IO () - biz = do - pure (10 :: Integer) - pure () - -biz' :: IO () -biz' = do - pure (10 :: Integer) - pure () ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -658,8 +658,8 @@ def onlyHsParLocs(x): """ ls = x.split("\n") filteredLines = (loc.strip() for (loc,hspar) in zip(ls,ls[5:]) - if hspar.strip().startswith("(HsPar") - and not "<no location info>" in loc) + if hspar.strip().startswith("(HsPar") + and not "<no location info>" in loc) return '\n'.join(filteredLines) test('T15242', normalise_errmsg_fun(onlyHsParLocs), compile, ['']) test('T15431', normal, compile, ['']) @@ -957,3 +957,4 @@ test('T17705', normal, compile, ['']) test('T14745', normal, compile, ['']) test('T26451', normal, compile, ['']) test('T26582', normal, compile, ['']) +test('ExpansionQLIm', normal, compile, ['']) ===================================== testsuite/tests/typecheck/should_fail/T25970.hs deleted ===================================== @@ -1,18 +0,0 @@ - -{-# LANGUAGE TypeFamilies #-} -module T25970 where - -y :: IO () -y = putStrLn "y" - - -type family K a where - K a = Bool - -x :: IO (K b) -x = do - y - pure () -- The error should point here or on the whole do block - -x' :: IO (K b) -x' = y >> pure () ===================================== testsuite/tests/typecheck/should_fail/T25996.hs deleted ===================================== @@ -1,20 +0,0 @@ - -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Wno-unused-local-binds #-} -{-# OPTIONS_GHC -Wno-unused-top-binds #-} - -module T25996 where - -main :: IO () -main = do - pure () - where - biz :: IO () - biz = do - pure (10 :: Integer) -- This warning should be reported only once - pure () - -biz' :: IO () -biz' = do - pure (10 :: Integer) - pure () ===================================== testsuite/tests/typecheck/should_fail/T7857.stderr ===================================== @@ -1,8 +1,7 @@ - T7857.hs:8:11: error: [GHC-39999] • Could not deduce ‘PrintfType a0’ arising from a use of ‘printf’ - from the context: PrintfArg t - bound by the inferred type of g :: PrintfArg t => t -> b + from the context: PrintfArg q + bound by the inferred type of g :: PrintfArg q => q -> b at T7857.hs:8:1-21 The type variable ‘a0’ is ambiguous Potentially matching instances: @@ -15,3 +14,4 @@ T7857.hs:8:11: error: [GHC-39999] • In the second argument of ‘($)’, namely ‘printf "" i’ In the expression: f $ printf "" i In an equation for ‘g’: g i = f $ printf "" i + ===================================== testsuite/tests/typecheck/should_fail/tcfail181.stderr ===================================== @@ -1,5 +1,5 @@ tcfail181.hs:17:9: error: [GHC-39999] - • Could not deduce ‘Monad m0’ arising from a record update + • Could not deduce ‘Monad m0’ arising from a use of ‘foo’ from the context: Monad m bound by the inferred type of wog :: Monad m => p -> Something (m Bool) e View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1a3afd5ca3b88ed0472319ef4d667cd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1a3afd5ca3b88ed0472319ef4d667cd… You're receiving this email because of your account on gitlab.haskell.org.

1 0