- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/abstract-q] wip: Abstract Q
by Teo Camarasu (＠teo) 12 Mar '26

12 Mar '26

Teo Camarasu pushed to branch wip/abstract-q at Glasgow Haskell Compiler / GHC Commits: 67f9f5be by Teo Camarasu at 2026-03-12T23:06:39+00:00 wip: Abstract Q - - - - - 3 changed files: - compiler/GHC/Data/IOEnv.hs - compiler/GHC/Tc/Gen/Splice.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs Changes: ===================================== compiler/GHC/Data/IOEnv.hs ===================================== @@ -29,7 +29,7 @@ module GHC.Data.IOEnv ( -- I/O operations IORef, newMutVar, readMutVar, writeMutVar, updMutVar, - atomicUpdMutVar, atomicUpdMutVar' + atomicUpdMutVar, atomicUpdMutVar', unliftIOEnv ) where import GHC.Prelude @@ -258,3 +258,10 @@ updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env)) updEnvIO :: (env -> IO env') -> IOEnv env' a -> IOEnv env a {-# INLINE updEnvIO #-} updEnvIO upd (IOEnv m) = IOEnv (\ env -> m =<< upd env) + +unliftIOEnv :: forall env b. ((forall a. IOEnv env a -> IO a) -> IO b) -> IOEnv env b +unliftIOEnv k = IOEnv $ \env -> + let + unlift :: forall a. IOEnv env a -> IO a + unlift (IOEnv m) = m env + in k unlift ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -138,6 +138,7 @@ import qualified GHC.LanguageExtensions as LangExt -- THSyntax gives access to internal functions and data types import qualified GHC.Boot.TH.Syntax as TH import qualified GHC.Boot.TH.Monad as TH +import GHC.Boot.TH.Monad (MetaHandlers(..)) import qualified GHC.Boot.TH.Ppr as TH #if defined(HAVE_INTERNAL_INTERPRETER) @@ -1139,7 +1140,7 @@ convertAnnotationWrapper fhv = do -} runQuasi :: TH.Q a -> TcM a -runQuasi act = TH.runQ act +runQuasi (TH.Q act) = runMetaHandlersInTcM metaHandlersTcM >>= liftIO . act runRemoteModFinalizers :: ThModFinalizers -> TcM () runRemoteModFinalizers (ThModFinalizers finRefs) = do @@ -1466,68 +1467,11 @@ when showing an error message. To call runQ in the Tc monad, we need to make TcM an instance of Quasi: -} -instance TH.Quasi TcM where - qNewName s = do { u <- newUnique - ; let i = toInteger (getKey u) - ; return (TH.mkNameU s i) } - - -- 'msg' is forced to ensure exceptions don't escape, - -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg - qReport False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg - - qLocation :: TcM TH.Loc - qLocation = do { m <- getModule - ; l <- getSrcSpanM - ; r <- case l of - UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" - (ppr l) - RealSrcSpan s _ -> return s - ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) - , TH.loc_module = moduleNameString (moduleName m) - , TH.loc_package = unitString (moduleUnit m) - , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) - , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } - - qLookupName = lookupName - qReify = reify - qReifyFixity nm = lookupThName nm >>= reifyFixity - qReifyType = reifyTypeOfThing - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness nm = do { nm' <- lookupThName nm - ; dc <- tcLookupDataCon nm' - ; let bangs = dataConImplBangs dc - ; return (map reifyDecidedStrictness bangs) } - - -- For qRecover, discard error messages if - -- the recovery action is chosen. Otherwise - -- we'll only fail higher up. - qRecover recover main = tryTcDiscardingErrs recover main - - qGetPackageRoot = do - dflags <- getDynFlags - return $ fromMaybe "." (workingDirectory dflags) - - qAddDependentFile fp = do - ref <- fmap tcg_dependent_files getGblEnv - dep_files <- readTcRef ref - writeTcRef ref (fp:dep_files) - - qAddDependentDirectory dp = do - ref <- fmap tcg_dependent_dirs getGblEnv - dep_dirs <- readTcRef ref - writeTcRef ref (dp:dep_dirs) - - qAddTempFile suffix = do - dflags <- getDynFlags - logger <- getLogger - tmpfs <- hsc_tmpfs <$> getTopEnv - liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix - - qAddTopDecls thds = do +report True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg +report False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg + +addTopDecls :: [TH.Dec] -> TcM () +addTopDecls thds = do exts <- fmap extensionFlags getDynFlags l <- getSrcSpanM th_origin <- getThSpliceOrigin @@ -1555,52 +1499,12 @@ instance TH.Quasi TcM where bindName :: RdrName -> TcM () bindName (Exact n) = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) - } + ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) + } bindName name = addErr $ TcRnTHError $ THNameError $ NonExactName name - qAddForeignFilePath lang fp = do - var <- fmap tcg_th_foreign_files getGblEnv - updTcRef var ((lang, fp) :) - - qAddModFinalizer fin = do - r <- liftIO $ mkRemoteRef fin - fref <- liftIO $ mkForeignRef r (freeRemoteRef r) - addModFinalizerRef fref - - qAddCorePlugin plugin = do - hsc_env <- getTopEnv - let fc = hsc_FC hsc_env - let home_unit = hsc_home_unit hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) - let err = TcRnTHError $ AddInvalidCorePlugin plugin - case r of - Found {} -> addErr err - FoundMultiple {} -> addErr err - _ -> return () - th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv - updTcRef th_coreplugins_var (plugin:) - - qGetQ :: forall a. Typeable a => TcM (Maybe a) - qGetQ = do - th_state_var <- fmap tcg_th_state getGblEnv - th_state <- readTcRef th_state_var - -- See #10596 for why we use a scoped type variable here. - return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) - - qPutQ x = do - th_state_var <- fmap tcg_th_state getGblEnv - updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) - - qIsExtEnabled = xoptM - - qExtsEnabled = - EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv - - qPutDoc doc_loc s = do +putDoc doc_loc s = do th_doc_var <- tcg_th_docs <$> getGblEnv resolved_doc_loc <- resolve_loc doc_loc is_local <- checkLocalName resolved_doc_loc @@ -1623,14 +1527,184 @@ instance TH.Quasi TcM where checkLocalName ModuleDoc = pure True - qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc - qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc - qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i - qGetDoc TH.ModuleDoc = do +getDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc +getDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc +getDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i +getDoc TH.ModuleDoc = do df <- getDynFlags docs <- getGblEnv >>= extractDocs df return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs)) +getQ :: forall a. Typeable a => TcM (Maybe a) +getQ = do + th_state_var <- fmap tcg_th_state getGblEnv + th_state <- readTcRef th_state_var + -- See #10596 for why we use a scoped type variable here. + return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) + +location :: TcM TH.Loc +location = do { m <- getModule + ; l <- getSrcSpanM + ; r <- case l of + UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" + (ppr l) + RealSrcSpan s _ -> return s + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = unitString (moduleUnit m) + , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) + , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } + +runMetaHandlersInTcM :: TH.MetaHandlers TcM -> TcM (TH.MetaHandlers IO) +runMetaHandlersInTcM mh = unliftIOEnv $ \unliftTcM -> do + let + unliftTcM2 :: (a -> b -> TcM c) -> a -> b -> IO c + unliftTcM2 m x y = unliftTcM (m x y) + pure $ TH.MetaHandlers { + mNewName = unliftTcM . mNewName mh + + -- 'msg' is forced to ensure exceptions don't escape, + -- see Note [Exceptions in TH] + , mReport = unliftTcM2 $ mReport mh + + , mLocation = unliftTcM $ mLocation mh + + , mLookupName = unliftTcM2 $ mLookupName mh + , mReify = unliftTcM . mReify mh + , mReifyFixity = unliftTcM . mReifyFixity mh + , mReifyType = unliftTcM . mReifyType mh + , mReifyInstances = unliftTcM2 $ mReifyInstances mh + , mReifyRoles = unliftTcM . mReifyRoles mh + , mReifyAnnotations = unliftTcM . mReifyAnnotations mh + , mReifyModule = unliftTcM . mReifyModule mh + , mReifyConStrictness = unliftTcM . mReifyConStrictness mh + + -- For qRecover, discard error messages if + -- the recovery action is chosen. Otherwise + -- we'll only fail higher up. + , mRecover = \recover main -> unliftTcM $ mRecover mh (liftIO recover) (liftIO main) + + , mGetPackageRoot = unliftTcM $ mGetPackageRoot mh + + , mAddDependentFile = unliftTcM . mAddDependentFile mh + + , mAddDependentDirectory = unliftTcM . mAddDependentDirectory mh + + , mAddTempFile = unliftTcM . mAddTempFile mh + + , mAddTopDecls = unliftTcM . mAddTopDecls mh + + , mAddForeignFilePath = unliftTcM2 $ mAddForeignFilePath mh + + , mAddModFinalizer = unliftTcM . mAddModFinalizer mh + + , mAddCorePlugin = unliftTcM . mAddCorePlugin mh + + , mGetQ = unliftTcM $ mGetQ mh + + , mPutQ = unliftTcM . mPutQ mh + + , mIsExtEnabled = unliftTcM . mIsExtEnabled mh + + , mExtsEnabled = unliftTcM $ mExtsEnabled mh + + , mPutDoc = unliftTcM2 $ mPutDoc mh + + , mGetDoc = unliftTcM . mGetDoc mh + } + +metaHandlersTcM :: TH.MetaHandlers TcM +metaHandlersTcM = TH.MetaHandlers { + mNewName = \s -> do { u <- newUnique + ; let i = toInteger (getKey u) + ; return (TH.mkNameU s i) } + + -- 'msg' is forced to ensure exceptions don't escape, + -- see Note [Exceptions in TH] + , mReport = report + + , mLocation = location + + , mLookupName = lookupName + , mReify = reify + , mReifyFixity = \nm -> lookupThName nm >>= reifyFixity + , mReifyType = reifyTypeOfThing + , mReifyInstances = reifyInstances + , mReifyRoles = reifyRoles + , mReifyAnnotations = reifyAnnotations + , mReifyModule = reifyModule + , mReifyConStrictness = \nm -> do { nm' <- lookupThName nm + ; dc <- tcLookupDataCon nm' + ; let bangs = dataConImplBangs dc + ; return (map reifyDecidedStrictness bangs) } + + -- For qRecover, discard error messages if + -- the recovery action is chosen. Otherwise + -- we'll only fail higher up. + , mRecover = \recover main -> tryTcDiscardingErrs recover main + + , mGetPackageRoot = do + dflags <- getDynFlags + return $ fromMaybe "." (workingDirectory dflags) + + , mAddDependentFile = \fp -> do + ref <- fmap tcg_dependent_files getGblEnv + dep_files <- readTcRef ref + writeTcRef ref (fp:dep_files) + + , mAddDependentDirectory = \dp -> do + ref <- fmap tcg_dependent_dirs getGblEnv + dep_dirs <- readTcRef ref + writeTcRef ref (dp:dep_dirs) + + , mAddTempFile = \suffix -> do + dflags <- getDynFlags + logger <- getLogger + tmpfs <- hsc_tmpfs <$> getTopEnv + liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix + + , mAddTopDecls = addTopDecls + + , mAddForeignFilePath = \lang fp -> do + var <- fmap tcg_th_foreign_files getGblEnv + updTcRef var ((lang, fp) :) + + , mAddModFinalizer = \fin -> do + r <- liftIO $ mkRemoteRef fin + fref <- liftIO $ mkForeignRef r (freeRemoteRef r) + addModFinalizerRef fref + + , mAddCorePlugin = \plugin -> do + hsc_env <- getTopEnv + let fc = hsc_FC hsc_env + let home_unit = hsc_home_unit hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags + r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) + let err = TcRnTHError $ AddInvalidCorePlugin plugin + case r of + Found {} -> addErr err + FoundMultiple {} -> addErr err + _ -> return () + th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv + updTcRef th_coreplugins_var (plugin:) + + , mGetQ = getQ + + , mPutQ = \x -> do + th_state_var <- fmap tcg_th_state getGblEnv + updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) + + , mIsExtEnabled = xoptM + + , mExtsEnabled = + EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv + + , mPutDoc = putDoc + + , mGetDoc = getDoc + } + -- | Looks up documentation for a declaration in first the current module, -- otherwise tries to find it in another module via 'hscGetModuleInterface'. lookupDeclDoc :: Name -> TcM (Maybe String) @@ -1795,7 +1869,7 @@ runTH ty fhv = do -- Remote GHCi, see Note [Remote Template Haskell] in -- libraries/ghci/GHCi/TH.hs. rstate <- getTHState inst - loc <- TH.qLocation + loc <- location -- run a remote TH request r <- liftIO $ withForeignRef rstate $ \state_hv -> @@ -1911,32 +1985,33 @@ wrapTHResult tcm = do handleTHMessage :: THMessage a -> TcM a handleTHMessage msg = case msg of - NewName a -> wrapTHResult $ TH.qNewName a - Report b str -> wrapTHResult $ TH.qReport b str - LookupName b str -> wrapTHResult $ TH.qLookupName b str - Reify n -> wrapTHResult $ TH.qReify n - ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n - ReifyType n -> wrapTHResult $ TH.qReifyType n - ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts - ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n - ReifyAnnotations lookup tyrep -> - wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) - ReifyModule m -> wrapTHResult $ TH.qReifyModule m - ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm - GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot - AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f - AddDependentDirectory d -> wrapTHResult $ TH.qAddDependentDirectory d - AddTempFile s -> wrapTHResult $ TH.qAddTempFile s - AddModFinalizer r -> do - interp <- hscInterp <$> getTopEnv - wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef - AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str - AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs - AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str - IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext - ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled - PutDoc l s -> wrapTHResult $ TH.qPutDoc l s - GetDoc l -> wrapTHResult $ TH.qGetDoc l + -- TODO + -- NewName a -> wrapTHResult $ TH.qNewName a + -- Report b str -> wrapTHResult $ TH.qReport b str + -- LookupName b str -> wrapTHResult $ TH.qLookupName b str + -- Reify n -> wrapTHResult $ TH.qReify n + -- ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n + -- ReifyType n -> wrapTHResult $ TH.qReifyType n + -- ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts + -- ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n + -- ReifyAnnotations lookup tyrep -> + -- wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) + -- ReifyModule m -> wrapTHResult $ TH.qReifyModule m + -- ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm + -- GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot + -- AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f + -- AddDependentDirectory d -> wrapTHResult $ TH.qAddDependentDirectory d + -- AddTempFile s -> wrapTHResult $ TH.qAddTempFile s + -- AddModFinalizer r -> do + -- interp <- hscInterp <$> getTopEnv + -- wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef + -- AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str + -- AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs + -- AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str + -- IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext + -- ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled + -- PutDoc l s -> wrapTHResult $ TH.qPutDoc l s + -- GetDoc l -> wrapTHResult $ TH.qGetDoc l FailIfErrs -> wrapTHResult failIfErrsM _ -> panic ("handleTHMessage: unexpected message " ++ show msg) ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Internal.TH.Syntax ----------------------------------------------------- class (MonadIO m, MonadFail m) => Quasi m where + qRunQ :: Q a -> m a -- | Fresh names. See 'newName'. qNewName :: String -> m Name @@ -149,6 +150,7 @@ class (MonadIO m, MonadFail m) => Quasi m where -- type environment, so reification isn't going to -- work. instance Quasi IO where + qRunQ (Q m) = m (MetaHandlers {}) -- TODO: create a metahandlers instance which matches the quasi instance, ie, mostly badIO qNewName = newNameIO qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) @@ -183,6 +185,86 @@ instance Quasi IO where instance Quote IO where newName = newNameIO +data MetaHandlers m = MetaHandlers { + -- | Fresh names. See 'newName'. + mNewName :: String -> m Name + + ------- Error reporting and recovery ------- + -- | Report an error (True) or warning (False) + -- ...but carry on; use 'fail' to stop. See 'report'. + , mReport :: Bool -> String -> m () + + -- | See 'recover'. + , mRecover :: forall a. m a -- ^ the error handler + -> m a -- ^ action which may fail + -> m a -- ^ Recover from the monadic 'fail' + + ------- Inspect the type-checker's environment ------- + -- | True <=> type namespace, False <=> value namespace. See 'lookupName'. + , mLookupName :: Bool -> String -> m (Maybe Name) + -- | See 'reify'. + , mReify :: Name -> m Info + -- | See 'reifyFixity'. + , mReifyFixity :: Name -> m (Maybe Fixity) + -- | See 'reifyType'. + , mReifyType :: Name -> m Type + -- | Is (n tys) an instance? Returns list of matching instance Decs (with + -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'. + , mReifyInstances :: Name -> [Type] -> m [Dec] + -- | See 'reifyRoles'. + , mReifyRoles :: Name -> m [Role] + -- | See 'reifyAnnotations'. + , mReifyAnnotations :: forall a. Data a => AnnLookup -> m [a] + -- | See 'reifyModule'. + , mReifyModule :: Module -> m ModuleInfo + -- | See 'reifyConStrictness'. + , mReifyConStrictness :: Name -> m [DecidedStrictness] + + -- | See 'location'. + , mLocation :: m Loc + + -- | See 'getPackageRoot'. + , mGetPackageRoot :: m FilePath + + -- | See 'addDependentFile'. + , mAddDependentFile :: FilePath -> m () + + -- | See 'addDependentDirectory'. + , mAddDependentDirectory :: FilePath -> m () + + -- | See 'addTempFile'. + , mAddTempFile :: String -> m FilePath + + -- | See 'addTopDecls'. + , mAddTopDecls :: [Dec] -> m () + + -- | See 'addForeignFilePath'. + , mAddForeignFilePath :: ForeignSrcLang -> String -> m () + + -- | See 'addModFinalizer'. + , mAddModFinalizer :: Q () -> m () + + -- | See 'addCorePlugin'. + , mAddCorePlugin :: String -> m () + + -- | See 'getQ'. + , mGetQ :: forall a. Typeable a => m (Maybe a) + + -- | See 'putQ'. + , mPutQ :: forall a. Typeable a => a -> m () + + -- | See 'isExtEnabled'. + , mIsExtEnabled :: Extension -> m Bool + -- | See 'extsEnabled'. + , mExtsEnabled :: m [Extension] + + -- | See 'putDoc'. + , mPutDoc :: DocLoc -> String -> m () + -- | See 'getDoc'. + , mGetDoc :: DocLoc -> m (Maybe String) + } + + newNameIO :: String -> IO Name newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x)) ; pure (mkNameU s n) } @@ -213,7 +295,7 @@ counter = unsafePerformIO (newIORef 0) -- inversion](https://en.wikipedia.org/wiki/Dependency_inversion_principle), -- providing an abstract interface for the user which is later concretely -- fufilled by an concrete 'Quasi' instance, internal to GHC. -newtype Q a = Q { unQ :: forall m. Quasi m => m a } +newtype Q a = Q { unQ :: MetaHandlers IO -> IO a } -- | \"Runs\" the 'Q' monad. Normal users of Template Haskell -- should not need this function, as the splice brackets @$( ... )@ @@ -227,22 +309,22 @@ newtype Q a = Q { unQ :: forall m. Quasi m => m a } -- simply fail at runtime. Indeed, the only operations guaranteed to succeed -- are 'newName', 'runIO', 'reportError' and 'reportWarning'. runQ :: Quasi m => Q a -> m a -runQ (Q m) = m +runQ = qRunQ instance Monad Q where - Q m >>= k = Q (m >>= \x -> unQ (k x)) + Q m >>= k = Q $ \h -> (m h >>= \x -> unQ (k x) h) (>>) = (*>) instance MonadFail Q where - fail s = report True s >> Q (fail "Q monad failure") + fail s = report True s >> Q (\h -> fail "Q monad failure") instance Functor Q where - fmap f (Q x) = Q (fmap f x) + fmap f (Q x) = Q $ \h -> fmap f (x h) instance Applicative Q where - pure x = Q (pure x) - Q f <*> Q x = Q (f <*> x) - Q m *> Q n = Q (m *> n) + pure x = Q $ \h -> (pure x) + Q f <*> Q x = Q $ \h -> (f h <*> x h) + Q m *> Q n = Q $ \h ->(m h *> n h) -- | @since 2.17.0.0 instance Semigroup a => Semigroup (Q a) where @@ -312,7 +394,7 @@ class Monad m => Quote m where newName :: String -> m Name instance Quote Q where - newName s = Q (qNewName s) + newName s = Q $ \h -> mNewName h s ----------------------------------------------------- -- @@ -510,7 +592,7 @@ joinCode = flip bindCode id -- | Report an error (True) or warning (False), -- but carry on; use 'fail' to stop. report :: Bool -> String -> Q () -report b s = Q (qReport b s) +report b s = Q $ \h -> mReport h b s {-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6 -- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'. @@ -525,20 +607,20 @@ reportWarning = report False recover :: Q a -- ^ handler to invoke on failure -> Q a -- ^ computation to run -> Q a -recover (Q r) (Q m) = Q (qRecover r m) +recover (Q r) (Q m) = Q $ \h -> mRecover h (r h) (m h) -- We don't export lookupName; the Bool isn't a great API -- Instead we export lookupTypeName, lookupValueName lookupName :: Bool -> String -> Q (Maybe Name) -lookupName ns s = Q (qLookupName ns s) +lookupName ns s = Q $ \h -> (mLookupName h ns s) -- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details. lookupTypeName :: String -> Q (Maybe Name) -lookupTypeName s = Q (qLookupName True s) +lookupTypeName s = Q $ \h -> (mLookupName h True s) -- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details. lookupValueName :: String -> Q (Maybe Name) -lookupValueName s = Q (qLookupName False s) +lookupValueName s = Q $ \h -> (mLookupName h False s) {- Note [Name lookup] @@ -613,7 +695,7 @@ To ensure we get information about @D@-the-value, use 'lookupValueName': and to get information about @D@-the-type, use 'lookupTypeName'. -} reify :: Name -> Q Info -reify v = Q (qReify v) +reify v = Q $ \h -> (mReify h v) {- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then @@ -622,7 +704,7 @@ example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then 'Nothing', so you may assume @bar@ has 'defaultFixity'. -} reifyFixity :: Name -> Q (Maybe Fixity) -reifyFixity nm = Q (qReifyFixity nm) +reifyFixity nm = Q $ \h ->(mReifyFixity h nm) {- | @reifyType nm@ attempts to find the type or kind of @nm@. For example, @reifyType 'not@ returns @Bool -> Bool@, and @@ -630,7 +712,7 @@ reifyFixity nm = Q (qReifyFixity nm) This works even if there's no explicit signature and the type or kind is inferred. -} reifyType :: Name -> Q Type -reifyType nm = Q (qReifyType nm) +reifyType nm = Q $ \h ->(mReifyType h nm) {- | Template Haskell is capable of reifying information about types and terms defined in previous declaration groups. Top-level declaration splices break up @@ -722,7 +804,7 @@ has some discussion around this. -} reifyInstances :: Name -> [Type] -> Q [InstanceDec] -reifyInstances cls tys = Q (qReifyInstances cls tys) +reifyInstances cls tys = Q $ \h ->(mReifyInstances h cls tys) {- | @reifyRoles nm@ returns the list of roles associated with the parameters (both visible and invisible) of @@ -741,20 +823,20 @@ and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' i the role of the invisible @k@ parameter. Kind parameters are always nominal. -} reifyRoles :: Name -> Q [Role] -reifyRoles nm = Q (qReifyRoles nm) +reifyRoles nm = Q $ \h -> (mReifyRoles h nm) -- | @reifyAnnotations target@ returns the list of annotations -- associated with @target@. Only the annotations that are -- appropriately typed is returned. So if you have @Int@ and @String@ -- annotations for the same target, you have to call this function twice. reifyAnnotations :: Data a => AnnLookup -> Q [a] -reifyAnnotations an = Q (qReifyAnnotations an) +reifyAnnotations an = Q $ \h -> (mReifyAnnotations h an) -- | @reifyModule mod@ looks up information about module @mod@. To -- look up the current module, call this function with the return -- value of 'Language.Haskell.TH.Lib.thisModule'. reifyModule :: Module -> Q ModuleInfo -reifyModule m = Q (qReifyModule m) +reifyModule m = Q $ \h -> (mReifyModule h m) -- | @reifyConStrictness nm@ looks up the strictness information for the fields -- of the constructor with the name @nm@. Note that the strictness information @@ -769,7 +851,7 @@ reifyModule m = Q (qReifyModule m) -- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the -- @-XStrictData@ language extension was enabled. reifyConStrictness :: Name -> Q [DecidedStrictness] -reifyConStrictness n = Q (qReifyConStrictness n) +reifyConStrictness n = Q $ \h ->(mReifyConStrictness h n) -- | Is the list of instances returned by 'reifyInstances' nonempty? -- @@ -782,7 +864,7 @@ isInstance nm tys = do { decs <- reifyInstances nm tys -- | The location at which this computation is spliced. location :: Q Loc -location = Q qLocation +location = Q mLocation -- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad. -- Take care: you are guaranteed the ordering of calls to 'runIO' within @@ -792,7 +874,7 @@ location = Q qLocation -- necessarily flushed when the compiler finishes running, so you should -- flush them yourself. runIO :: IO a -> Q a -runIO m = Q (qRunIO m) +runIO m = Q $ \h -> m -- | Get the package root for the current package which is being compiled. -- This can be set explicitly with the -package-root flag but is normally @@ -804,7 +886,7 @@ runIO m = Q (qRunIO m) -- change directory when compiling files but instead set the -package-root flag -- appropriately. getPackageRoot :: Q FilePath -getPackageRoot = Q qGetPackageRoot +getPackageRoot = Q mGetPackageRoot -- | Record external directories that runIO is using (dependent upon). -- The compiler can then recognize that it should re-compile the Haskell file @@ -823,7 +905,7 @@ getPackageRoot = Q qGetPackageRoot -- * The state of the directory is read at the interface generation time, -- not at the time of the function call. addDependentDirectory :: FilePath -> Q () -addDependentDirectory dp = Q (qAddDependentDirectory dp) +addDependentDirectory dp = Q $ \h -> (mAddDependentDirectory h dp) -- | Record external files that runIO is using (dependent upon). -- The compiler can then recognize that it should re-compile the Haskell file @@ -837,17 +919,17 @@ addDependentDirectory dp = Q (qAddDependentDirectory dp) -- -- * The dependency is based on file content, not a modification time addDependentFile :: FilePath -> Q () -addDependentFile fp = Q (qAddDependentFile fp) +addDependentFile fp = Q $ \h -> (mAddDependentFile h fp) -- | Obtain a temporary file path with the given suffix. The compiler will -- delete this file after compilation. addTempFile :: String -> Q FilePath -addTempFile suffix = Q (qAddTempFile suffix) +addTempFile suffix = Q $ \h -> (mAddTempFile h suffix) -- | Add additional top-level declarations. The added declarations will be type -- checked along with the current declaration group. addTopDecls :: [Dec] -> Q () -addTopDecls ds = Q (qAddTopDecls ds) +addTopDecls ds = Q $ \h ->(mAddTopDecls h ds) -- | Same as 'addForeignSource', but expects to receive a path pointing to the -- foreign file instead of a 'String' of its contents. Consider using this in @@ -856,7 +938,7 @@ addTopDecls ds = Q (qAddTopDecls ds) -- This is a good alternative to 'addForeignSource' when you are trying to -- directly link in an object file. addForeignFilePath :: ForeignSrcLang -> FilePath -> Q () -addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp) +addForeignFilePath lang fp = Q $ \h ->(mAddForeignFilePath h lang fp) -- | Add a finalizer that will run in the Q monad after the current module has -- been type checked. This only makes sense when run within a top-level splice. @@ -865,7 +947,7 @@ addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp) -- 'reify' is able to find the local definitions when executed inside the -- finalizer. addModFinalizer :: Q () -> Q () -addModFinalizer act = Q (qAddModFinalizer (unQ act)) +addModFinalizer act = Q $ \h -> mAddModFinalizer h act -- | Adds a core plugin to the compilation pipeline. -- @@ -875,7 +957,7 @@ addModFinalizer act = Q (qAddModFinalizer (unQ act)) -- to tell the compiler that we needed to compile first a plugin module in the -- current package. addCorePlugin :: String -> Q () -addCorePlugin plugin = Q (qAddCorePlugin plugin) +addCorePlugin plugin = Q $ \h -> mAddCorePlugin h plugin -- | Get state from the 'Q' monad. The state maintained by 'Q' is isomorphic to -- a type-indexed finite map. That is, @@ -889,20 +971,20 @@ addCorePlugin plugin = Q (qAddCorePlugin plugin) -- Note that the state is local to the Haskell module in which the Template -- Haskell expression is executed. getQ :: Typeable a => Q (Maybe a) -getQ = Q qGetQ +getQ = Q mGetQ -- | Replace the state in the 'Q' monad. Note that the state is local to the -- Haskell module in which the Template Haskell expression is executed. putQ :: Typeable a => a -> Q () -putQ x = Q (qPutQ x) +putQ x = Q $ \h -> mPutQ h x -- | Determine whether the given language extension is enabled in the 'Q' monad. isExtEnabled :: Extension -> Q Bool -isExtEnabled ext = Q (qIsExtEnabled ext) +isExtEnabled ext = Q $ \h -> mIsExtEnabled h ext -- | List all enabled language extensions. extsEnabled :: Q [Extension] -extsEnabled = Q qExtsEnabled +extsEnabled = Q $ mExtsEnabled -- | Add Haddock documentation to the specified location. This will overwrite -- any documentation at the location if it already exists. This will reify the @@ -921,19 +1003,20 @@ extsEnabled = Q qExtsEnabled -- Adding documentation to anything outside of the current module will cause an -- error. putDoc :: DocLoc -> String -> Q () -putDoc t s = Q (qPutDoc t s) +putDoc t s = Q $ \h -> mPutDoc h t s -- | Retrieves the Haddock documentation at the specified location, if one -- exists. -- It can be used to read documentation on things defined outside of the current -- module, provided that those modules were compiled with the @-haddock@ flag. getDoc :: DocLoc -> Q (Maybe String) -getDoc n = Q (qGetDoc n) +getDoc n = Q $ \h ->mGetDoc h n instance MonadIO Q where liftIO = runIO instance Quasi Q where + qRunQ = id qNewName = newName qReport = report qRecover = recover View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67f9f5bec67da9729eaa7d99b557270… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67f9f5bec67da9729eaa7d99b557270… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/abstract-q
by Teo Camarasu (＠teo) 12 Mar '26

12 Mar '26

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

1 0

[Git][ghc/ghc][wip/ani/kill-CodeSrcFlag] 38 commits: Work for #25001
by Apoorv Ingle (＠ani) 12 Mar '26

12 Mar '26

Apoorv Ingle pushed to branch wip/ani/kill-CodeSrcFlag at Glasgow Haskell Compiler / GHC Commits: 505b57cf by Apoorv Ingle at 2026-03-09T16:27:08-05:00 Work for #25001 Notes added [Error Context Stack] [Typechecking by expansion: overview] Notes updated Note [Expanding HsDo with XXExprGhcRn] ------------------------- Metric Decrease: T9020 ------------------------- * Streamlines implementations of `tcExpr` and `tcXExpr` to work on `XExpr` * Kills `VACtxt` (and its associated `VAExpansion` and `VACall`) datatype, it is subsumed by simply a `SrcSpan`. * Kills the function `addHeadCtxt` as it is now mearly setting a location * The function `tcValArgs` does its own argument number management * Makes `splitHsApps` not look through `XExpr` * `tcExprSigma` is called if the head of the expression after calling `splitHsApps` turns out to be an `XExpr` * Removes location information from `OrigPat` payload * Removes special case of tcBody from `tcLambdaMatches` * Removes special case of `dsExpr` for `ExpandedThingTc` * Rename `HsThingRn` to `SrcCodeCtxt` * Kills `tcl_in_gen_code` and `tcl_err_ctxt`. It is subsumed by `ErrCtxtStack` * Kills `ExpectedFunTyOrig`. It is subsumed by `CtOrigin` * Fixes `CtOrigin` for `HsProjection` case in `exprCtOrigin`. It was previously assigned to be `SectionOrigin`. It is now just the expression * Adds a new `CtOrigin.ExpansionOrigin` for storing the original syntax * Adds a new `CtOrigin.ExpectedTySyntax` as a replacement for `ExpectedTySyntaxOp`. Cannot kill the former yet because of `ApplicativeDo` * Renames `tcMonoExpr` -> `tcMonoLExpr`, `tcMonoExprNC` -> `tcMonoLExpr` * Renames `EValArg`, `EValArgQL` fields: `ea_ctxt` -> `ea_loc_span` and `eaql_ctx` -> `eaql_loc_span` * kill `PopErrCtxt` from `XXExprGhcRn` * simplify `addArgCtxt` and push `setSrcSpan` inside `addLExprCtxt`. Make sure addExprCtxt is not called by itself * fun_orig in tcApp depends on the SrcSpan of the head of the application chain (similar to addArgCtxt) * rename fun_ctxt to fun_lspan, fun_orig passed in tcInstFun to default to app chain head if its user located, fall back to srcCodeOrigin if it's a generated location * fix quickLookArg function to blame the correct application chain head. The arguments application chain head should be blamed, not the original head when we quick look arg * Make sure only expression wrapped around generated src span are ignored while adding them to the error context stack * `getDeepSubsumptionFlag_DataConHead` performs a non-trivial traversal if the expression passed to it is complex. This traversal is necessary if the head of the function is an `XExpr` and `splitHsApps` does not look through them - The deepsubsumption flag is stored in EVAlArgQL to reduce the need to call `getDeepSubsumptionFlag_DataConHead` - `getDeepSubsumptionFlag_DataConHead` is called in `tcExprSigma` and `tcInferAppHead` to reduce AST traversals * Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes * wrap `fromListN` with a generated src span with GeneratedSrcSpanDetails field to store the original srcspan * remove `UnhelpfulGenerated` from `UnhelpfulSpanReason` and into new datatype `GeneratedSrcSpanDetails` - - - - - faaeb7b9 by Apoorv Ingle at 2026-03-09T16:27:37-05:00 trying to remove SrcCodeOrigin - - - - - c675c814 by Simon Peyton Jones at 2026-03-09T16:27:38-05:00 Improvements in ErrCtxt - - - - - af429f43 by Apoorv Ingle at 2026-03-09T16:27:39-05:00 ErrCtxtMsg to CtOrigin - - - - - 1ff61903 by Apoorv Ingle at 2026-03-09T16:27:39-05:00 remove CtOrigin.ExpansionOrigin in favour of errCtxtCtOrigin, remove CtOrign from ErrMsgCtxt.FunTysCtxt - - - - - ba2b691f by Apoorv Ingle at 2026-03-09T16:27:39-05:00 trying out ErrCtxtMsg zonking - - - - - 8f52b02f by Apoorv Ingle at 2026-03-09T16:27:40-05:00 route the correct ExpectedFunTyCtxt SDoc. Add missing RecordUpdCtxt to errCtxtCtOrigin - - - - - f921f0d3 by Apoorv Ingle at 2026-03-09T16:27:40-05:00 print the correct exprs for warnings for do discards - - - - - c6f2ab89 by Apoorv Ingle at 2026-03-09T19:16:59-05:00 fixes for error message diffs for RepPolyBinds etc. - - - - - d0f2dc6f by Apoorv Ingle at 2026-03-09T22:17:16-05:00 add zonking for PatSigErrCtxt, fix err string for pprExpectedFunTyCtxt - - - - - dd34f3ec by Apoorv Ingle at 2026-03-11T17:23:53-05:00 make Data instance for ErrCtxtMsg, accept test cases - - - - - 18772d5c by Apoorv Ingle at 2026-03-11T17:59:39-05:00 rename ErrCtxtMsg -> HsCtxt - - - - - 8780dc92 by Apoorv Ingle at 2026-03-11T19:26:22-05:00 remove add***ErrM variants as they are no longer monadic. remove DoStmtErrCtxt from HsCtxt. - - - - - a4df18d0 by Rajkumar Natarajan at 2026-03-12T16:25:17-05:00 chore: Merge GHC.Internal.TH.Quote into GHC.Internal.TH.Monad Move the QuasiQuoter datatype from GHC.Internal.TH.Quote to GHC.Internal.TH.Monad and delete the Quote module. Update submodule template-haskell-quasiquoter to use the merged upstream version that imports from the correct module. Co-authored-by: Cursor <cursoragent(a)cursor.com> - - - - - 1f234da7 by Simon Jakobi at 2026-03-12T16:25:17-05:00 Add regression test for #16122 - - - - - 9572f6e9 by Cheng Shao at 2026-03-12T16:25:17-05:00 hadrian: remove the broken bench flavour This patch removes the bench flavour from hadrian which has been broken for years and not used for actual benchmarking (for which `perf`/`release` is used instead). Closes #26825. - - - - - db174d15 by Simon Jakobi at 2026-03-12T16:25:17-05:00 Add regression test for #18186 The original TypeInType language extension is replaced with DataKinds+PolyKinds for compatibility. Closes #18186. - - - - - d4d44c32 by Andreas Klebinger at 2026-03-12T16:25:17-05:00 Bump nofib submodule. We accrued a number of nofib fixes we want to have here. - - - - - b72bd0e2 by Simon Jakobi at 2026-03-12T16:25:17-05:00 Add regression test for #15907 Closes #15907. - - - - - f652da00 by Simon Jakobi at 2026-03-12T16:25:17-05:00 Ensure T14272 is run in optasm way Closes #16539. - - - - - f71b8aba by Simon Jakobi at 2026-03-12T16:25:17-05:00 Add regression test for #24632 Closes #24632. - - - - - c1c0c687 by Simon Jakobi at 2026-03-12T16:25:17-05:00 Fix module name of T9675: T6975 -> T9675 - - - - - 66d0f48a by Andreas Klebinger at 2026-03-12T16:25:17-05:00 User guide: Clarify phase control on INLINEABLE[foo] pragmas. Fixes #26851 - - - - - 179ef220 by Simon Jakobi at 2026-03-12T16:25:17-05:00 Add regression test for #12694 Closes #12694. - - - - - a8b7332c by Simon Jakobi at 2026-03-12T16:25:17-05:00 Add regression test for #16275 Closes #16275. - - - - - ca98d28d by Simon Jakobi at 2026-03-12T16:25:17-05:00 Add regression test for #14908 Closes #14908. - - - - - 999b7fdf by Simon Jakobi at 2026-03-12T16:25:17-05:00 Add regression test for #14151 Closes #14151. - - - - - c1be3e34 by Simon Jakobi at 2026-03-12T16:25:17-05:00 Add regression test for #12640 Closes #12640. - - - - - bf3183ae by Simon Jakobi at 2026-03-12T16:25:17-05:00 Add regression test for #15588 Closes #15588. - - - - - 84ca0079 by Simon Jakobi at 2026-03-12T16:25:17-05:00 Add regression test for #9445 Closes #9445. - - - - - e4d81164 by Cheng Shao at 2026-03-12T16:25:17-05:00 compiler: implement string interning logic for BCONPtrFS This patch adds a `FastStringEnv`-based cache of `MallocStrings` requests to `Interp`, so that when we load bytecode with many breakpoints that share the same module names & unit ids, we reuse the allocated remote pointers instead of issuing duplicte `MallocStrings` requests and bloating the C heap. Closes #26995. - - - - - 8684a569 by Simon Jakobi at 2026-03-12T16:25:17-05:00 Add perf test for #1216 Closes #1216. - - - - - c77df83d by Sylvain Henry at 2026-03-12T16:25:17-05:00 JS: check that tuple constructors are linked (#23709) Test js-mk_tup was failing before because tuple constructors weren't linked in. It's no longer an issue after the linker fixes. - - - - - 68304361 by Matthew Pickering at 2026-03-12T16:25:17-05:00 testsuite: Add test for foreign import prim with unboxed tuple return This commit just adds a test that foreign import prim works with unboxed sums. - - - - - 76e50eab by Matthew Pickering at 2026-03-12T16:25:17-05:00 Return a valid pointer in advanceStackFrameLocationzh When there is no next stack chunk, `advanceStackFrameLocationzh` used to return NULL in the pointer-typed StackSnapshot# result slot. Even though the caller treats that case as "no next frame", the result is still materialized in a GC-visible pointer slot. If a GC observes the raw NULL there, stack decoding can crash. Fix this by ensuring the dead pointer slot contains a valid closure pointer. Also make the optional result explicit by returning an unboxed sum instead of a tuple with a separate tag. Fixes #27009 - - - - - 3399557a by Cheng Shao at 2026-03-12T16:25:17-05:00 hadrian: build profiled dynamic objects with -dynamic-too This patch enables hadrian to build profiled dynamic objects with `-dynamic-too`, addressing a build parallelism bottleneck in release pipelines. Closes #27010. - - - - - 5be3e1de by Apoorv Ingle at 2026-03-12T16:25:17-05:00 hie refactoring - - - - - 59c5e841 by Apoorv Ingle at 2026-03-12T17:33:52-05:00 remove dependencies on CodeSrcFlag make VDQWarningCtxt landmark make addExpansionErrCtxt also sets tcl_in_gen_code - - - - - 176 changed files: - compiler/GHC.hs - compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Expr.hs-boot - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - + compiler/GHC/Tc/Gen/App.hs-boot - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/BasicTypes.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/Origin.hs-boot - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcType.hs-boot - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Error.hs - + compiler/GHC/Types/Error.hs-boot - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/SrcLoc.hs - + compiler/GHC/Unit/State.hs-boot - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/exts/pragmas.rst - docs/users_guide/exts/rewrite_rules.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - hadrian/doc/flavours.md - hadrian/hadrian.cabal - hadrian/src/Rules/Compile.hs - hadrian/src/Settings.hs - hadrian/src/Settings/Builders/Ghc.hs - − hadrian/src/Settings/Flavours/Benchmark.hs - libraries/ghc-boot-th/GHC/Boot/TH/Quote.hs - libraries/ghc-internal/cbits/Stack.cmm - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - − libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs - libraries/template-haskell-quasiquoter - nofib - + testsuite/tests/corelint/T15907.hs - + testsuite/tests/corelint/T15907A.hs - testsuite/tests/corelint/all.T - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - + testsuite/tests/dependent/should_fail/T15588.hs - + testsuite/tests/dependent/should_fail/T15588.stderr - testsuite/tests/dependent/should_fail/all.T - + testsuite/tests/ffi/should_run/PrimFFIUnboxedSum.hs - + testsuite/tests/ffi/should_run/PrimFFIUnboxedSum.stdout - + testsuite/tests/ffi/should_run/PrimFFIUnboxedSum_cmm.cmm - testsuite/tests/ffi/should_run/all.T - + testsuite/tests/ghci/scripts/T24632.hs - + testsuite/tests/ghci/scripts/T24632.script - + testsuite/tests/ghci/scripts/T24632.stdout - testsuite/tests/ghci/scripts/all.T - testsuite/tests/indexed-types/should_fail/T2693.stderr - testsuite/tests/indexed-types/should_fail/T5439.stderr - testsuite/tests/javascript/js-mk_tup.hs - testsuite/tests/javascript/js-mk_tup.stdout - testsuite/tests/linters/Makefile - testsuite/tests/monadfail/MonadFailErrors.stderr - testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr - testsuite/tests/perf/compiler/T9675.hs - + testsuite/tests/perf/should_run/T1216.hs - + testsuite/tests/perf/should_run/T1216.stdout - testsuite/tests/perf/should_run/all.T - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/plugins/test-defaulting-plugin.stderr - + testsuite/tests/polykinds/T18186.hs - + testsuite/tests/polykinds/T18186.stderr - testsuite/tests/polykinds/all.T - testsuite/tests/printer/T17697.stderr - testsuite/tests/quotes/QQError.stderr - testsuite/tests/rebindable/rebindable6.stderr - testsuite/tests/rep-poly/RepPolyDoBind.stderr - testsuite/tests/rep-poly/RepPolyDoBody1.stderr - testsuite/tests/rep-poly/RepPolyDoBody2.stderr - testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr - + testsuite/tests/simplCore/should_compile/T12640.hs - + testsuite/tests/simplCore/should_compile/T12640.stderr - + testsuite/tests/simplCore/should_compile/T14908.hs - + testsuite/tests/simplCore/should_compile/T14908_Deps.hs - + testsuite/tests/simplCore/should_compile/T16122.hs - + testsuite/tests/simplCore/should_compile/T16122.stderr - + testsuite/tests/simplCore/should_compile/T9445.hs - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/th/QQTopError.stderr - + testsuite/tests/typecheck/should_compile/ExpansionQLIm.hs - + testsuite/tests/typecheck/should_compile/T14151.hs - testsuite/tests/typecheck/should_compile/T14590.stderr - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/T10971d.stderr - + testsuite/tests/typecheck/should_fail/T12694.hs - + testsuite/tests/typecheck/should_fail/T12694.stderr - testsuite/tests/typecheck/should_fail/T13311.stderr - + testsuite/tests/typecheck/should_fail/T16275.stderr - + testsuite/tests/typecheck/should_fail/T16275A.hs - + testsuite/tests/typecheck/should_fail/T16275B.hs - + testsuite/tests/typecheck/should_fail/T16275B.hs-boot - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T3613.stderr - testsuite/tests/typecheck/should_fail/T6069.stderr - testsuite/tests/typecheck/should_fail/T7851.stderr - testsuite/tests/typecheck/should_fail/T7857.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/typecheck/should_fail/tcfail102.stderr - testsuite/tests/typecheck/should_fail/tcfail128.stderr - testsuite/tests/typecheck/should_fail/tcfail140.stderr - testsuite/tests/typecheck/should_fail/tcfail181.stderr - utils/check-exact/ExactPrint.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/575ad32e32d76d6c4be7f1d695a4e1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/575ad32e32d76d6c4be7f1d695a4e1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wasm-iserv-fast-binary] ghci: serialize BCOByteArray buffer directly when possible
by Cheng Shao (＠TerrorJack) 12 Mar '26

12 Mar '26

Cheng Shao pushed to branch wip/wasm-iserv-fast-binary at Glasgow Haskell Compiler / GHC Commits: 0acb4ae1 by Cheng Shao at 2026-03-12T22:04:38+00:00 ghci: serialize BCOByteArray buffer directly when possible This patch changes the `Binary` instances of `BCOByteArray` to directly serialize the underlying buffer when possible, while also taking into account the issue of host-dependent `Word` width. See added comments and amended `Note [BCOByteArray serialization]` for detailed explanation. Closes #27020. - - - - - 2 changed files: - libraries/ghci/GHCi/ResolvedBCO.hs - testsuite/tests/ghci/should_run/BinaryArray.hs Changes: ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -9,17 +9,29 @@ module GHCi.ResolvedBCO , mkBCOByteArray ) where +#include "MachDeps.h" + import Prelude -- See note [Why do we import Prelude here?] import GHC.Data.SizedSeq import GHCi.RemoteTypes import GHCi.BreakArray -import Data.Binary +#if SIZEOF_HSWORD == 4 +import Control.Monad +import Data.Array.Base (foldrArray, listArray) +import Data.ByteString.Builder.Extra +import Foreign.Storable +#endif + +import Data.Binary (Binary(..)) +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString.Short (ShortByteString(..)) +import Data.Word import GHC.Generics -import Foreign.Storable import GHC.Exts -import Data.Array.Base (IArray, UArray(..)) +import Data.Array.Base (UArray(..)) #include "MachDeps.h" @@ -58,15 +70,23 @@ data BCOByteArray a getBCOByteArray :: !ByteArray# } +#if SIZEOF_HSWORD == 4 fromBCOByteArray :: forall a . Storable a => BCOByteArray a -> UArray Int a fromBCOByteArray (BCOByteArray ba#) = UArray 0 (n - 1) n ba# where len# = sizeofByteArray# ba# n = (I# len#) `div` sizeOf (undefined :: a) +#endif mkBCOByteArray :: UArray Int a -> BCOByteArray a mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr +putFixedWidthBCOByteArray :: BCOByteArray a -> Put +putFixedWidthBCOByteArray (BCOByteArray ba#) = put $ SBS ba# + +getFixedWidthBCOByteArray :: Get (BCOByteArray a) +getFixedWidthBCOByteArray = (\(SBS ba#) -> BCOByteArray ba#) <$> get + instance Show (BCOByteArray Word16) where showsPrec _ _ = showString "BCOByteArray Word16" @@ -89,10 +109,40 @@ instance Binary ResolvedBCO where get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get -- See Note [BCOByteArray serialization] -instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) where - put = put . fromBCOByteArray - get = mkBCOByteArray <$> get - +instance Binary (BCOByteArray Word16) where + put = putFixedWidthBCOByteArray + get = getFixedWidthBCOByteArray + +-- Word size depends on host, which is tricky when host/target word +-- sizes differ. We always serialize `BCOByteArray Word` as +-- `BCOByteArray Word64`. +instance Binary (BCOByteArray Word) where +#if SIZEOF_HSWORD == 8 + -- 64-bit fast path. `BCOByteArray` is directly serialized via the + -- `Binary ShortByteString` instance, which serializes the `Int` + -- bytelength first (via `Int64` transparently), then copies the + -- buffer. + put = putFixedWidthBCOByteArray + + get = getFixedWidthBCOByteArray +#else + -- 32-bit slow path. Pretend it's a `BCOByteArray Word64` and handle + -- the bytelength & buffer elements directly. + put ba32@(BCOByteArray ba32#) = + put len64 *> + putBuilder + (foldrArray (\w32 acc -> word64Host (fromIntegral w32) <> acc) mempty arr32) + where + len32# = sizeofByteArray# ba32# + len64 = I# len32# * 2 + arr32 = fromBCOByteArray ba32 + + get = do + len64 <- get + let len = len64 `div` 8 + w32s <- replicateM len (fromIntegral <$> getWord64host) + pure $ mkBCOByteArray $ listArray (0, len - 1) w32s +#endif data ResolvedBCOPtr = ResolvedBCORef {-# UNPACK #-} !Int @@ -124,12 +174,17 @@ instance Binary ResolvedBCOPtr -- The root issue here is the usage of platform sized integer types in -- BCO (and any messages we pass between ghc/iserv really), we should -- do what we already do for RemotePtr: always use Word64 instead of --- Word. But that takes much more work, and there's an easier --- mitigation: keep BCOByteArray as ByteArray#, but serialize it as --- UArray, given the Binary instances are independent of platform word --- size and endianness, so each Word/Int is always serialized as --- 64-bit big-endian Word64/Int64, and the entire UArray is serialized --- as a list (length+elements). +-- Word. +-- +-- When we serialize `BCOByteArray Word16`, element is fixed width on +-- 32/64-bit host, so we can directly serialize the buffer per se. For +-- `BCOByteArray Word`, we must always serialize it as `BCOByteArray +-- Word64`, and hence it has fast-path/slow-path decided at +-- compile-time, see comments of `instance Binary (BCOByteArray Word)` +-- for explanation. These are the only two `Binary` instances we ever +-- use, so to avoid unnecessary complexity, we're fine with flexible +-- instances here, instead of generalizing to any element type that +-- may be fixed-width or not. -- -- Since we erase the metadata in UArray, we need to find a way to -- calculate the item count by dividing the ByteArray# length with ===================================== testsuite/tests/ghci/should_run/BinaryArray.hs ===================================== @@ -24,7 +24,7 @@ roundtripTest arr = Left _ -> putStrLn "deserialization failed" -- See Note [BCOByteArray serialization] -roundtripTestByteArray :: forall a . (IArray UArray a, MArray IOUArray a IO, Eq a, Binary a, Storable a) +roundtripTestByteArray :: forall a . (IArray UArray a, Eq a, Binary (BCOByteArray a)) => UArray Int a -> IO () roundtripTestByteArray (UArray _ _ _ arr#) = let val = BCOByteArray arr# :: BCOByteArray a @@ -44,10 +44,5 @@ main = do roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word32) roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word64) roundtripTest (AU.listArray (1,500) ['a'..] :: UArray Int Char) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Int) roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word8) roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word16) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word32) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word64) - roundtripTestByteArray (AU.listArray (1,500) ['a'..] :: UArray Int Char) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0acb4ae16a78739f8924795d12619f1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0acb4ae16a78739f8924795d12619f1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wasm-iserv-fast-binary] ghci: serialize BCOByteArray buffer directly when possible
by Cheng Shao (＠TerrorJack) 12 Mar '26

12 Mar '26

Cheng Shao pushed to branch wip/wasm-iserv-fast-binary at Glasgow Haskell Compiler / GHC Commits: 1520fd8f by Cheng Shao at 2026-03-12T21:56:35+00:00 ghci: serialize BCOByteArray buffer directly when possible This patch changes the `Binary` instances of `BCOByteArray` to directly serialize the underlying buffer when possible, while also taking into account the issue of host-dependent `Word` width. See added comments and amended `Note [BCOByteArray serialization]` for detailed explanation. Closes #27020. - - - - - 2 changed files: - libraries/ghci/GHCi/ResolvedBCO.hs - testsuite/tests/ghci/should_run/BinaryArray.hs Changes: ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -9,12 +9,24 @@ module GHCi.ResolvedBCO , mkBCOByteArray ) where +#include "MachDeps.h" + import Prelude -- See note [Why do we import Prelude here?] import GHC.Data.SizedSeq import GHCi.RemoteTypes import GHCi.BreakArray -import Data.Binary +#if SIZEOF_HSWORD == 4 +import Control.Monad +import Data.Array.Base (foldrArray, listArray) +import Data.ByteString.Builder.Extra +#endif + +import Data.Binary (Binary(..)) +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString.Short (ShortByteString(..)) +import Data.Word import GHC.Generics import Foreign.Storable @@ -58,15 +70,23 @@ data BCOByteArray a getBCOByteArray :: !ByteArray# } +#if SIZEOF_HSWORD == 4 fromBCOByteArray :: forall a . Storable a => BCOByteArray a -> UArray Int a fromBCOByteArray (BCOByteArray ba#) = UArray 0 (n - 1) n ba# where len# = sizeofByteArray# ba# n = (I# len#) `div` sizeOf (undefined :: a) +#endif mkBCOByteArray :: UArray Int a -> BCOByteArray a mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr +putFixedWidthBCOByteArray :: BCOByteArray a -> Put +putFixedWidthBCOByteArray (BCOByteArray ba#) = put $ SBS ba# + +getFixedWidthBCOByteArray :: Get (BCOByteArray a) +getFixedWidthBCOByteArray = (\(SBS ba#) -> BCOByteArray ba#) <$> get + instance Show (BCOByteArray Word16) where showsPrec _ _ = showString "BCOByteArray Word16" @@ -89,10 +109,40 @@ instance Binary ResolvedBCO where get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get -- See Note [BCOByteArray serialization] -instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) where - put = put . fromBCOByteArray - get = mkBCOByteArray <$> get - +instance Binary (BCOByteArray Word16) where + put = putFixedWidthBCOByteArray + get = getFixedWidthBCOByteArray + +-- Word size depends on host, which is tricky when host/target word +-- sizes differ. We always serialize `BCOByteArray Word` as +-- `BCOByteArray Word64`. +instance Binary (BCOByteArray Word) where +#if SIZEOF_HSWORD == 8 + -- 64-bit fast path. `BCOByteArray` is directly serialized via the + -- `Binary ShortByteString` instance, which serializes the `Int` + -- bytelength first (via `Int64` transparently), then copies the + -- buffer. + put = putFixedWidthBCOByteArray + + get = getFixedWidthBCOByteArray +#else + -- 32-bit slow path. Pretend it's a `BCOByteArray Word64` and handle + -- the bytelength & buffer elements directly. + put ba32@(BCOByteArray ba32#) = + put len64 *> + putBuilder + (foldrArray (\w32 acc -> word64Host (fromIntegral w32) <> acc) mempty arr32) + where + len32# = sizeofByteArray# ba32# + len64 = I# len32# * 2 + arr32 = fromBCOByteArray ba32 + + get = do + len64 <- get + let len = len64 `div` 8 + w32s <- replicateM len (fromIntegral <$> getWord64host) + pure $ mkBCOByteArray $ listArray (0, len - 1) w32s +#endif data ResolvedBCOPtr = ResolvedBCORef {-# UNPACK #-} !Int @@ -124,12 +174,17 @@ instance Binary ResolvedBCOPtr -- The root issue here is the usage of platform sized integer types in -- BCO (and any messages we pass between ghc/iserv really), we should -- do what we already do for RemotePtr: always use Word64 instead of --- Word. But that takes much more work, and there's an easier --- mitigation: keep BCOByteArray as ByteArray#, but serialize it as --- UArray, given the Binary instances are independent of platform word --- size and endianness, so each Word/Int is always serialized as --- 64-bit big-endian Word64/Int64, and the entire UArray is serialized --- as a list (length+elements). +-- Word. +-- +-- When we serialize `BCOByteArray Word16`, element is fixed width on +-- 32/64-bit host, so we can directly serialize the buffer per se. For +-- `BCOByteArray Word`, we must always serialize it as `BCOByteArray +-- Word64`, and hence it has fast-path/slow-path decided at +-- compile-time, see comments of `instance Binary (BCOByteArray Word)` +-- for explanation. These are the only two `Binary` instances we ever +-- use, so to avoid unnecessary complexity, we're fine with flexible +-- instances here, instead of generalizing to any element type that +-- may be fixed-width or not. -- -- Since we erase the metadata in UArray, we need to find a way to -- calculate the item count by dividing the ByteArray# length with ===================================== testsuite/tests/ghci/should_run/BinaryArray.hs ===================================== @@ -24,7 +24,7 @@ roundtripTest arr = Left _ -> putStrLn "deserialization failed" -- See Note [BCOByteArray serialization] -roundtripTestByteArray :: forall a . (IArray UArray a, MArray IOUArray a IO, Eq a, Binary a, Storable a) +roundtripTestByteArray :: forall a . (IArray UArray a, Eq a, Binary (BCOByteArray a)) => UArray Int a -> IO () roundtripTestByteArray (UArray _ _ _ arr#) = let val = BCOByteArray arr# :: BCOByteArray a @@ -44,10 +44,5 @@ main = do roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word32) roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word64) roundtripTest (AU.listArray (1,500) ['a'..] :: UArray Int Char) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Int) roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word8) roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word16) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word32) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word64) - roundtripTestByteArray (AU.listArray (1,500) ['a'..] :: UArray Int Char) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1520fd8f67a39f96d36af8ae16be41e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1520fd8f67a39f96d36af8ae16be41e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wasm-iserv-fast-binary] ghci: serialize BCOByteArray buffer directly when possible
by Cheng Shao (＠TerrorJack) 12 Mar '26

12 Mar '26

Cheng Shao pushed to branch wip/wasm-iserv-fast-binary at Glasgow Haskell Compiler / GHC Commits: cf35c584 by Cheng Shao at 2026-03-12T21:54:14+00:00 ghci: serialize BCOByteArray buffer directly when possible This patch changes the `Binary` instances of `BCOByteArray` to directly serialize the underlying buffer when possible, while also taking into account the issue of host-dependent `Word` width. See added comments and amended `Note [BCOByteArray serialization]` for detailed explanation. Closes #27020. - - - - - 2 changed files: - libraries/ghci/GHCi/ResolvedBCO.hs - testsuite/tests/ghci/should_run/BinaryArray.hs Changes: ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -9,12 +9,24 @@ module GHCi.ResolvedBCO , mkBCOByteArray ) where +#include "MachDeps.h" + import Prelude -- See note [Why do we import Prelude here?] import GHC.Data.SizedSeq import GHCi.RemoteTypes import GHCi.BreakArray -import Data.Binary +#if SIZEOF_HSWORD == 4 +import Control.Monad +import Data.Array.Base (foldrArray, listArray) +import Data.ByteString.Builder.Extra +#endif + +import Data.Binary (Binary(..)) +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString.Short (ShortByteString(..)) +import Data.Word import GHC.Generics import Foreign.Storable @@ -67,6 +79,12 @@ fromBCOByteArray (BCOByteArray ba#) = UArray 0 (n - 1) n ba# mkBCOByteArray :: UArray Int a -> BCOByteArray a mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr +putFixedWidthBCOByteArray :: BCOByteArray a -> Put +putFixedWidthBCOByteArray (BCOByteArray ba#) = put $ SBS ba# + +getFixedWidthBCOByteArray :: Get (BCOByteArray a) +getFixedWidthBCOByteArray = (\(SBS ba#) -> BCOByteArray ba#) <$> get + instance Show (BCOByteArray Word16) where showsPrec _ _ = showString "BCOByteArray Word16" @@ -89,10 +107,40 @@ instance Binary ResolvedBCO where get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get -- See Note [BCOByteArray serialization] -instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) where - put = put . fromBCOByteArray - get = mkBCOByteArray <$> get - +instance Binary (BCOByteArray Word16) where + put = putFixedWidthBCOByteArray + get = getFixedWidthBCOByteArray + +-- Word size depends on host, which is tricky when host/target word +-- sizes differ. We always serialize `BCOByteArray Word` as +-- `BCOByteArray Word64`. +instance Binary (BCOByteArray Word) where +#if SIZEOF_HSWORD == 8 + -- 64-bit fast path. `BCOByteArray` is directly serialized via the + -- `Binary ShortByteString` instance, which serializes the `Int` + -- bytelength first (via `Int64` transparently), then copies the + -- buffer. + put = putFixedWidthBCOByteArray + + get = getFixedWidthBCOByteArray +#else + -- 32-bit slow path. Pretend it's a `BCOByteArray Word64` and handle + -- the bytelength & buffer elements directly. + put ba32@(BCOByteArray ba32#) = + put len64 *> + putBuilder + (foldrArray (\w32 acc -> word64Host (fromIntegral w32) <> acc) mempty arr32) + where + len32# = sizeofByteArray# ba32# + len64 = I# len32# * 2 + arr32 = fromBCOByteArray ba32 + + get = do + len64 <- get + let len = len64 `div` 8 + w32s <- replicateM len (fromIntegral <$> getWord64host) + pure $ mkBCOByteArray $ listArray (0, len - 1) w32s +#endif data ResolvedBCOPtr = ResolvedBCORef {-# UNPACK #-} !Int @@ -124,12 +172,17 @@ instance Binary ResolvedBCOPtr -- The root issue here is the usage of platform sized integer types in -- BCO (and any messages we pass between ghc/iserv really), we should -- do what we already do for RemotePtr: always use Word64 instead of --- Word. But that takes much more work, and there's an easier --- mitigation: keep BCOByteArray as ByteArray#, but serialize it as --- UArray, given the Binary instances are independent of platform word --- size and endianness, so each Word/Int is always serialized as --- 64-bit big-endian Word64/Int64, and the entire UArray is serialized --- as a list (length+elements). +-- Word. +-- +-- When we serialize `BCOByteArray Word16`, element is fixed width on +-- 32/64-bit host, so we can directly serialize the buffer per se. For +-- `BCOByteArray Word`, we must always serialize it as `BCOByteArray +-- Word64`, and hence it has fast-path/slow-path decided at +-- compile-time, see comments of `instance Binary (BCOByteArray Word)` +-- for explanation. These are the only two `Binary` instances we ever +-- use, so to avoid unnecessary complexity, we're fine with flexible +-- instances here, instead of generalizing to any element type that +-- may be fixed-width or not. -- -- Since we erase the metadata in UArray, we need to find a way to -- calculate the item count by dividing the ByteArray# length with ===================================== testsuite/tests/ghci/should_run/BinaryArray.hs ===================================== @@ -24,7 +24,7 @@ roundtripTest arr = Left _ -> putStrLn "deserialization failed" -- See Note [BCOByteArray serialization] -roundtripTestByteArray :: forall a . (IArray UArray a, MArray IOUArray a IO, Eq a, Binary a, Storable a) +roundtripTestByteArray :: forall a . (IArray UArray a, Eq a, Binary (BCOByteArray a)) => UArray Int a -> IO () roundtripTestByteArray (UArray _ _ _ arr#) = let val = BCOByteArray arr# :: BCOByteArray a @@ -44,10 +44,5 @@ main = do roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word32) roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word64) roundtripTest (AU.listArray (1,500) ['a'..] :: UArray Int Char) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Int) roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word8) roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word16) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word32) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word64) - roundtripTestByteArray (AU.listArray (1,500) ['a'..] :: UArray Int Char) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cf35c584e0eefd7eea97cfbdca7718c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cf35c584e0eefd7eea97cfbdca7718c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wasm-iserv-fast-binary] ghci: serialize BCOByteArray buffer directly when possible
by Cheng Shao (＠TerrorJack) 12 Mar '26

12 Mar '26

Cheng Shao pushed to branch wip/wasm-iserv-fast-binary at Glasgow Haskell Compiler / GHC Commits: d8f9fd56 by Cheng Shao at 2026-03-12T21:47:38+00:00 ghci: serialize BCOByteArray buffer directly when possible This patch changes the `Binary` instances of `BCOByteArray` to directly serialize the underlying buffer when possible, while also taking into account the issue of host-dependent `Word` width. See added comments and amended `Note [BCOByteArray serialization]` for detailed explanation. Closes #27020. - - - - - 2 changed files: - libraries/ghci/GHCi/ResolvedBCO.hs - testsuite/tests/ghci/should_run/BinaryArray.hs Changes: ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -14,12 +14,23 @@ import GHC.Data.SizedSeq import GHCi.RemoteTypes import GHCi.BreakArray -import Data.Binary +#if SIZEOF_HSWORD == 4 +import Control.Monad +import Data.Array.Base (IArray, UArray(..), foldrArray, listArray) +import Data.ByteString.Builder.Extra +#else +import Data.Array.Base (IArray, UArray(..)) +#endif + +import Data.Binary (Binary(..)) +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString.Short (ShortByteString(..)) +import Data.Word import GHC.Generics import Foreign.Storable import GHC.Exts -import Data.Array.Base (IArray, UArray(..)) #include "MachDeps.h" @@ -67,6 +78,12 @@ fromBCOByteArray (BCOByteArray ba#) = UArray 0 (n - 1) n ba# mkBCOByteArray :: UArray Int a -> BCOByteArray a mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr +putFixedWidthBCOByteArray :: BCOByteArray a -> Put +putFixedWidthBCOByteArray (BCOByteArray ba#) = put $ SBS ba# + +getFixedWidthBCOByteArray :: Get (BCOByteArray a) +getFixedWidthBCOByteArray = (\(SBS ba#) -> BCOByteArray ba#) <$> get + instance Show (BCOByteArray Word16) where showsPrec _ _ = showString "BCOByteArray Word16" @@ -89,10 +106,40 @@ instance Binary ResolvedBCO where get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get -- See Note [BCOByteArray serialization] -instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) where - put = put . fromBCOByteArray - get = mkBCOByteArray <$> get - +instance Binary (BCOByteArray Word16) where + put = putFixedWidthBCOByteArray + get = getFixedWidthBCOByteArray + +-- Word size depends on host, which is tricky when host/target word +-- sizes differ. We always serialize `BCOByteArray Word` as +-- `BCOByteArray Word64`. +instance Binary (BCOByteArray Word) where +#if SIZEOF_HSWORD == 8 + -- 64-bit fast path. `BCOByteArray` is directly serialized via the + -- `Binary ShortByteString` instance, which serializes the `Int` + -- bytelength first (via `Int64` transparently), then copies the + -- buffer. + put = putFixedWidthBCOByteArray + + get = getFixedWidthBCOByteArray +#else + -- 32-bit slow path. Pretend it's a `BCOByteArray Word64` and handle + -- the bytelength & buffer elements directly. + put ba32@(BCOByteArray ba32#) = + put len64 *> + putBuilder + (foldrArray (\w32 acc -> word64Host (fromIntegral w32) <> acc) mempty arr32) + where + len32# = sizeofByteArray# ba32# + len64 = I# len32# * 2 + arr32 = fromBCOByteArray ba32 + + get = do + len64 <- get + let len = len64 `div` 8 + w32s <- replicateM len (fromIntegral <$> getWord64host) + pure $ mkBCOByteArray $ listArray (0, len - 1) w32s +#endif data ResolvedBCOPtr = ResolvedBCORef {-# UNPACK #-} !Int @@ -124,12 +171,17 @@ instance Binary ResolvedBCOPtr -- The root issue here is the usage of platform sized integer types in -- BCO (and any messages we pass between ghc/iserv really), we should -- do what we already do for RemotePtr: always use Word64 instead of --- Word. But that takes much more work, and there's an easier --- mitigation: keep BCOByteArray as ByteArray#, but serialize it as --- UArray, given the Binary instances are independent of platform word --- size and endianness, so each Word/Int is always serialized as --- 64-bit big-endian Word64/Int64, and the entire UArray is serialized --- as a list (length+elements). +-- Word. +-- +-- When we serialize `BCOByteArray Word16`, element is fixed width on +-- 32/64-bit host, so we can directly serialize the buffer per se. For +-- `BCOByteArray Word`, we must always serialize it as `BCOByteArray +-- Word64`, and hence it has fast-path/slow-path decided at +-- compile-time, see comments of `instance Binary (BCOByteArray Word)` +-- for explanation. These are the only two `Binary` instances we ever +-- use, so to avoid unnecessary complexity, we're fine with flexible +-- instances here, instead of generalizing to any element type that +-- may be fixed-width or not. -- -- Since we erase the metadata in UArray, we need to find a way to -- calculate the item count by dividing the ByteArray# length with ===================================== testsuite/tests/ghci/should_run/BinaryArray.hs ===================================== @@ -24,7 +24,7 @@ roundtripTest arr = Left _ -> putStrLn "deserialization failed" -- See Note [BCOByteArray serialization] -roundtripTestByteArray :: forall a . (IArray UArray a, MArray IOUArray a IO, Eq a, Binary a, Storable a) +roundtripTestByteArray :: forall a . (IArray UArray a, Eq a, Binary (BCOByteArray a)) => UArray Int a -> IO () roundtripTestByteArray (UArray _ _ _ arr#) = let val = BCOByteArray arr# :: BCOByteArray a @@ -44,10 +44,5 @@ main = do roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word32) roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word64) roundtripTest (AU.listArray (1,500) ['a'..] :: UArray Int Char) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Int) roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word8) roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word16) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word32) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word64) - roundtripTestByteArray (AU.listArray (1,500) ['a'..] :: UArray Int Char) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d8f9fd56bc539e524b67c63d402c881… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d8f9fd56bc539e524b67c63d402c881… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wasm-iserv-fast-binary] ghci: serialize BCOByteArray buffer directly when possible
by Cheng Shao (＠TerrorJack) 12 Mar '26

12 Mar '26

Cheng Shao pushed to branch wip/wasm-iserv-fast-binary at Glasgow Haskell Compiler / GHC Commits: b0da3066 by Cheng Shao at 2026-03-12T21:32:19+00:00 ghci: serialize BCOByteArray buffer directly when possible This patch changes the `Binary` instances of `BCOByteArray` to directly serialize the underlying buffer when possible, while also taking into account the issue of host-dependent `Word` width. See added comments and amended `Note [BCOByteArray serialization]` for detailed explanation. Closes #27020. - - - - - 2 changed files: - libraries/ghci/GHCi/ResolvedBCO.hs - testsuite/tests/ghci/should_run/BinaryArray.hs Changes: ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -14,7 +14,17 @@ import GHC.Data.SizedSeq import GHCi.RemoteTypes import GHCi.BreakArray -import Data.Binary +#if SIZEOF_HSWORD == 4 +import Control.Monad +import Data.Array.Base (foldrArray, listArray) +import Data.ByteString.Builder.Extra +#endif + +import Data.Binary (Binary(..)) +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString.Short (ShortByteString(..)) +import Data.Word import GHC.Generics import Foreign.Storable @@ -67,6 +77,12 @@ fromBCOByteArray (BCOByteArray ba#) = UArray 0 (n - 1) n ba# mkBCOByteArray :: UArray Int a -> BCOByteArray a mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr +putFixedWidthBCOByteArray :: BCOByteArray a -> Put +putFixedWidthBCOByteArray (BCOByteArray ba#) = put $ SBS ba# + +getFixedWidthBCOByteArray :: Get (BCOByteArray a) +getFixedWidthBCOByteArray = (\(SBS ba#) -> BCOByteArray ba#) <$> get + instance Show (BCOByteArray Word16) where showsPrec _ _ = showString "BCOByteArray Word16" @@ -89,10 +105,40 @@ instance Binary ResolvedBCO where get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get -- See Note [BCOByteArray serialization] -instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) where - put = put . fromBCOByteArray - get = mkBCOByteArray <$> get - +instance Binary (BCOByteArray Word16) where + put = putFixedWidthBCOByteArray + get = getFixedWidthBCOByteArray + +-- Word size depends on host, which is tricky when host/target word +-- sizes differ. We always serialize `BCOByteArray Word` as +-- `BCOByteArray Word64`. +instance Binary (BCOByteArray Word) where +#if SIZEOF_HSWORD == 8 + -- 64-bit fast path. `BCOByteArray` is directly serialized via the + -- `Binary ShortByteString` instance, which serializes the `Int` + -- bytelength first (via `Int64` transparently), then copies the + -- buffer. + put = putFixedWidthBCOByteArray + + get = getFixedWidthBCOByteArray +#else + -- 32-bit slow path. Pretend it's a `BCOByteArray Word64` and handle + -- the bytelength & buffer elements directly. + put ba32@(BCOByteArray ba32#) = + put len64 *> + putBuilder + (foldrArray (\w32 acc -> word64Host (fromIntegral w32) <> acc) mempty arr32) + where + len32# = sizeofByteArray# ba32# + len64 = I# len32# * 2 + arr32 = fromBCOByteArray ba32 + + get = do + len64 <- get + let len = len64 `div` 8 + w32s <- replicateM len (fromIntegral <$> getWord64host) + pure $ mkBCOByteArray $ listArray (0, len - 1) w32s +#endif data ResolvedBCOPtr = ResolvedBCORef {-# UNPACK #-} !Int @@ -124,12 +170,17 @@ instance Binary ResolvedBCOPtr -- The root issue here is the usage of platform sized integer types in -- BCO (and any messages we pass between ghc/iserv really), we should -- do what we already do for RemotePtr: always use Word64 instead of --- Word. But that takes much more work, and there's an easier --- mitigation: keep BCOByteArray as ByteArray#, but serialize it as --- UArray, given the Binary instances are independent of platform word --- size and endianness, so each Word/Int is always serialized as --- 64-bit big-endian Word64/Int64, and the entire UArray is serialized --- as a list (length+elements). +-- Word. +-- +-- When we serialize `BCOByteArray Word16`, element is fixed width on +-- 32/64-bit host, so we can directly serialize the buffer per se. For +-- `BCOByteArray Word`, we must always serialize it as `BCOByteArray +-- Word64`, and hence it has fast-path/slow-path decided at +-- compile-time, see comments of `instance Binary (BCOByteArray Word)` +-- for explanation. These are the only two `Binary` instances we ever +-- use, so to avoid unnecessary complexity, we're fine with flexible +-- instances here, instead of generalizing to any element type that +-- may be fixed-width or not. -- -- Since we erase the metadata in UArray, we need to find a way to -- calculate the item count by dividing the ByteArray# length with ===================================== testsuite/tests/ghci/should_run/BinaryArray.hs ===================================== @@ -24,7 +24,7 @@ roundtripTest arr = Left _ -> putStrLn "deserialization failed" -- See Note [BCOByteArray serialization] -roundtripTestByteArray :: forall a . (IArray UArray a, MArray IOUArray a IO, Eq a, Binary a, Storable a) +roundtripTestByteArray :: forall a . (IArray UArray a, Eq a, Binary (BCOByteArray a)) => UArray Int a -> IO () roundtripTestByteArray (UArray _ _ _ arr#) = let val = BCOByteArray arr# :: BCOByteArray a @@ -44,10 +44,5 @@ main = do roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word32) roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word64) roundtripTest (AU.listArray (1,500) ['a'..] :: UArray Int Char) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Int) roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word8) roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word16) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word32) - roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word64) - roundtripTestByteArray (AU.listArray (1,500) ['a'..] :: UArray Int Char) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b0da306612708701fe48f8e30120154… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b0da306612708701fe48f8e30120154… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/wasm-iserv-fast-binary
by Cheng Shao (＠TerrorJack) 12 Mar '26

12 Mar '26

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

1 0

[Git][ghc/ghc][wip/ani/kill-CodeSrcFlag] make addExpansionErrCtxt also sets tcl_in_gen_code
by Apoorv Ingle (＠ani) 12 Mar '26

12 Mar '26

Apoorv Ingle pushed to branch wip/ani/kill-CodeSrcFlag at Glasgow Haskell Compiler / GHC Commits: 575ad32e by Apoorv Ingle at 2026-03-12T16:24:04-05:00 make addExpansionErrCtxt also sets tcl_in_gen_code - - - - - 1 changed file: - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1376,7 +1376,7 @@ addErrCtxt msg = addErrCtxtM msg -- See Note [ErrCtxtStack Manipulation] addExpansionErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addExpansionErrCtxt #-} -- Note [Inlining addErrCtxt] -addExpansionErrCtxt msg = addExpansionErrCtxtM msg +addExpansionErrCtxt msg thing_inside = setInGeneratedCode $ addExpansionErrCtxtM msg thing_inside -- | Add a message to the error context. This message may do tidying. -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/575ad32e32d76d6c4be7f1d695a4e18… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/575ad32e32d76d6c4be7f1d695a4e18… You're receiving this email because of your account on gitlab.haskell.org.

1 0