Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 8adfc222 by sheaf at 2025-08-28T19:47:17-04:00 Fix orientation in HsWrapper composition (<.>) This commit fixes the order in which WpCast HsWrappers are composed, fixing a bug introduced in commit 56b32c5a2d5d7cad89a12f4d74dc940e086069d1. Fixes #26350 - - - - - b9f585ab by Oleg Grenrus at 2025-08-29T03:00:22-04:00 Generalise thNameToGhcName by adding HasHscEnv There were multiple single monad-specific `getHscEnv` across codebase. HasHscEnv is modelled on HasDynFlags. My first idea was to simply add thNameToGhcNameHsc and thNameToGhcNameTc, but those would been exactly the same as thNameToGhcName already. Also add an usage example to thNameToGhcName and mention that it's recommended way of looking up names in GHC plugins - - - - - 52ba0a3d by fendor at 2025-08-29T03:00:23-04:00 configure: Bump minimal bootstrap GHC version to 9.10 - - - - - 12 changed files: - .gitlab-ci.yml - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Plugins.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Types/Evidence.hs - configure.ac - + testsuite/tests/typecheck/should_compile/T26350.hs - testsuite/tests/typecheck/should_compile/all.T Changes: ===================================== .gitlab-ci.yml ===================================== @@ -104,6 +104,7 @@ workflow: # which versions of GHC to allow bootstrap with .bootstrap_matrix : &bootstrap_matrix matrix: + # If you update this version, be sure to also update 'MinBootGhcVersion' in configure.ac - GHC_VERSION: 9.10.1 DOCKER_IMAGE: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb12-ghc9_10:$DOCKER_REV" - GHC_VERSION: 9.12.2 ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -16,7 +16,7 @@ module GHC.Core.Opt.Monad ( mapDynFlagsCoreM, dropSimplCount, -- ** Reading from the monad - getHscEnv, getModule, + getModule, initRuleEnv, getExternalRuleBase, getDynFlags, getPackageFamInstEnv, getInteractiveContext, @@ -243,8 +243,8 @@ liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> re ************************************************************************ -} -getHscEnv :: CoreM HscEnv -getHscEnv = read cr_hsc_env +instance HasHscEnv CoreM where + getHscEnv = read cr_hsc_env getHomeRuleBase :: CoreM RuleBase getHomeRuleBase = read cr_rule_base ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -2,6 +2,7 @@ module GHC.Driver.Env ( Hsc(..) , HscEnv (..) + , HasHscEnv (..) , hsc_mod_graph , setModuleGraph , hscUpdateFlags @@ -49,7 +50,7 @@ import GHC.Driver.Errors ( printOrThrowDiagnostics ) import GHC.Driver.Errors.Types ( GhcMessage ) import GHC.Driver.Config.Logger (initLogFlags) import GHC.Driver.Config.Diagnostic (initDiagOpts, initPrintConfig) -import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) ) +import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..), HasHscEnv (..) ) import GHC.Runtime.Context import GHC.Runtime.Interpreter.Types (Interp) ===================================== compiler/GHC/Driver/Env/Types.hs ===================================== @@ -3,6 +3,7 @@ module GHC.Driver.Env.Types ( Hsc(..) , HscEnv(..) + , HasHscEnv(..) ) where import GHC.Driver.Errors.Types ( GhcMessage ) @@ -34,6 +35,9 @@ newtype Hsc a = Hsc (HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage deriving (Functor, Applicative, Monad, MonadIO) via ReaderT HscEnv (StateT (Messages GhcMessage) IO) +instance HasHscEnv Hsc where + getHscEnv = Hsc $ \e w -> return (e, w) + instance HasDynFlags Hsc where getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) @@ -109,3 +113,5 @@ data HscEnv -- ^ LLVM configuration cache. } +class HasHscEnv m where + getHscEnv :: m HscEnv ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -368,9 +368,6 @@ clearDiagnostics = Hsc $ \_ _ -> return ((), emptyMessages) logDiagnostics :: Messages GhcMessage -> Hsc () logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionMessages` w) -getHscEnv :: Hsc HscEnv -getHscEnv = Hsc $ \e w -> return (e, w) - handleWarnings :: Hsc () handleWarnings = do diag_opts <- initDiagOpts <$> getDynFlags ===================================== compiler/GHC/Plugins.hs ===================================== @@ -143,7 +143,7 @@ import Data.Maybe import GHC.Iface.Env ( lookupNameCache ) import GHC.Prelude -import GHC.Utils.Monad ( mapMaybeM ) +import GHC.Utils.Monad ( MonadIO, mapMaybeM ) import GHC.ThToHs ( thRdrNameGuesses ) import GHC.Tc.Utils.Env ( lookupGlobal ) import GHC.Types.Name.Cache ( NameCache ) @@ -178,7 +178,22 @@ instance MonadThings CoreM where -- exactly. Qualified or unqualified TH names will be dynamically bound -- to names in the module being compiled, if possible. Exact TH names -- will be bound to the name they represent, exactly. -thNameToGhcName :: TH.Name -> CoreM (Maybe Name) +-- +-- 'thNameToGhcName' can be used in 'CoreM', 'Hsc' and 'TcM' monads. +-- +-- 'thNameToGhcName' is recommended way to lookup 'Name's in GHC plugins. +-- +-- @ +-- {-# LANGUAGE TemplateHaskellQuotes #-} +-- +-- getNames :: Hsc (Maybe Name, Maybe Name) +-- getNames = do +-- class_Eq <- thNameToGhcName ''Eq +-- fun_eq <- thNameToGhcName '(==) +-- return (classEq, fun_eq) +-- @ +-- +thNameToGhcName :: (MonadIO m, HasHscEnv m) => TH.Name -> m (Maybe Name) thNameToGhcName th_name = do hsc_env <- getHscEnv liftIO $ thNameToGhcNameIO (hsc_NC hsc_env) th_name ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -2641,8 +2641,8 @@ runBc hsc_env this_mod mbs (BcM m) instance HasDynFlags BcM where getDynFlags = hsc_dflags <$> getHscEnv -getHscEnv :: BcM HscEnv -getHscEnv = BcM $ \env st -> return (bcm_hsc_env env, st) +instance HasHscEnv BcM where + getHscEnv = BcM $ \env st -> return (bcm_hsc_env env, st) getProfile :: BcM Profile getProfile = targetProfile <$> getDynFlags ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -430,7 +430,7 @@ tcApp rn_expr exp_res_ty -- Step 5.2: typecheck the arguments, and monomorphise -- any un-unified instantiation variables ; tc_args <- tcValArgs DoQL inst_args - -- Step 5.3: zonk to expose the polymophism hidden under + -- Step 5.3: zonk to expose the polymorphism hidden under -- QuickLook instantiation variables in `app_res_rho` ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho -- Step 5.4: subsumption check against the expected type ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -206,9 +206,15 @@ instance Monoid HsWrapper where (<.>) :: HsWrapper -> HsWrapper -> HsWrapper WpHole <.> c = c c <.> WpHole = c -WpCast c1 <.> WpCast c2 = WpCast (c1 `mkTransCo` c2) +WpCast c1 <.> WpCast c2 = WpCast (c2 `mkTransCo` c1) -- If we can represent the HsWrapper as a cast, try to do so: this may avoid -- unnecessary eta-expansion (see 'mkWpFun'). + -- + -- NB: <.> behaves like function composition: + -- + -- WpCast c1 <.> WpCast c2 :: coercionLKind c2 ~> coercionRKind c1 + -- + -- This is thus the same as WpCast (c2 ; c1) and not WpCast (c1 ; c2). c1 <.> c2 = c1 `WpCompose` c2 -- | Smart constructor to create a 'WpFun' 'HsWrapper', which avoids introducing ===================================== configure.ac ===================================== @@ -219,7 +219,7 @@ if test "$WithGhc" = "" then AC_MSG_ERROR([GHC is required.]) fi -MinBootGhcVersion="9.8" +MinBootGhcVersion="9.10" FP_COMPARE_VERSIONS([$GhcVersion],[-lt],[$MinBootGhcVersion], [AC_MSG_ERROR([GHC version $MinBootGhcVersion or later is required to compile GHC.])]) ===================================== testsuite/tests/typecheck/should_compile/T26350.hs ===================================== @@ -0,0 +1,18 @@ +{-# LANGUAGE DeepSubsumption #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -dcore-lint #-} + +module T26350 where + +import Control.Arrow (first) + +infix 6 .-. + +class AffineSpace p where + type Diff p + (.-.) :: p -> p -> Diff p + +affineCombo :: (AffineSpace p, v ~ Diff p) => p -> (p,v) -> (v,v) +affineCombo z l = first (.-. z) l ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -862,6 +862,7 @@ test('DeepSubsumption06', normal, compile, ['-XHaskell98']) test('DeepSubsumption07', normal, compile, ['-XHaskell2010']) test('DeepSubsumption08', normal, compile, ['']) test('DeepSubsumption09', normal, compile, ['']) +test('T26350', normal, compile, ['']) test('T26225', normal, compile, ['']) test('T26225b', normal, compile, ['']) test('T21765', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dbbb3c391d47e9ff04ec4bb858f7094... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dbbb3c391d47e9ff04ec4bb858f7094... You're receiving this email because of your account on gitlab.haskell.org.