- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/abstract-q] Make Q abstract
by Teo Camarasu (＠teo) 08 Jun '26

08 Jun '26

Teo Camarasu pushed to branch wip/abstract-q at Glasgow Haskell Compiler / GHC Commits: ce1298c9 by Teo Camarasu at 2026-06-08T15:01:00+01:00 Make Q abstract This patch aims to clearly demarcate the internal and external interfaces of Q. In the past the `Quasi` typeclass was both part of the external, public-facing interface, and was used to give the implementation of `Q`. Now we separate out these two distinct roles. `Quasi` continues to exist in the public interface, but we introduce a new `MetaHandlers` type, which is equivalent to `Dict Quasi`. `Q a` is now defined to be `MetaHandlers IO -> IO a`, and, crucially, the constructor and the new `MetaHandlers` type are not exposed from the public interface. This gives us the ability to vary the interface on the GHC side without forcing a breaking change on the `template-haskell` side. Similarly `template-haskell` has more freedom to change the `Quasi` typeclass without needing any changes in `lib:ghc`. Implements https://github.com/ghc-proposals/ghc-proposals/pull/70 Resolves #27341 - - - - - 9 changed files: - + changelog.d/AbstractQ - compiler/GHC/Data/IOEnv.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Gen/Splice.hs-boot - libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/ghci/GHCi/TH.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/tests/interface-stability/template-haskell-exports.stdout Changes: ===================================== changelog.d/AbstractQ ===================================== @@ -0,0 +1,7 @@ +section: template-haskell +synopsis: Hide the implementation of Q +description: The constructor of Q is now hidden. + This is done to improve the stability of ``template-haskell``. + To minimize breakage, we have added a new ``qRunQ`` operation to ``Quasi``. +mrs: !15696 +issues: #27341 ===================================== 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,11 @@ 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) + +-- | Provide a continuation with a function that allows unlifting 'IOEnv' computations into 'IO'. +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 ===================================== @@ -25,7 +25,7 @@ module GHC.Tc.Gen.Splice( tcTypedSplice, tcTypedBracket, tcUntypedBracket, runAnnotation, getUntypedSpliceBody, - runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, + runMetaE, runMetaP, runMetaT, runMetaD, runQinTcM, tcTopSpliceExpr, lookupThName_maybe, defaultRunMeta, runMeta', runRemoteModFinalizers, finishTH, runTopSplice @@ -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) @@ -1138,8 +1139,8 @@ convertAnnotationWrapper fhv = do ************************************************************************ -} -runQuasi :: TH.Q a -> TcM a -runQuasi act = TH.runQ act +runQinTcM :: TH.Q a -> TcM a +runQinTcM (TH.Q act) = unliftIOEnv $ \runInIO -> liftIO $ act (metaHandlersTcM runInIO) runRemoteModFinalizers :: ThModFinalizers -> TcM () runRemoteModFinalizers (ThModFinalizers finRefs) = do @@ -1152,7 +1153,7 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do #if defined(HAVE_INTERNAL_INTERPRETER) InternalInterp -> do qs <- liftIO (withForeignRefs finRefs $ mapM localRef) - runQuasi $ sequence_ qs + runQinTcM $ sequence_ qs #endif ExternalInterp ext -> withExtInterp ext $ \inst -> do @@ -1466,70 +1467,14 @@ 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] +report :: Bool -> [Char] -> TcM () +report True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg +report False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg - -- '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 - RealSrcSpan s _ -> return s - GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan" - (pprGeneratedSrcSpanDetails) - UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" - (ppr l) - ; 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 +addTopDecls :: [TH.Dec] -> TcM () +addTopDecls thds = do exts <- fmap extensionFlags getDynFlags l <- getSrcSpanM th_origin <- getThSpliceOrigin @@ -1557,52 +1502,13 @@ 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 :: TH.DocLoc -> String -> TcM () +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 @@ -1624,15 +1530,133 @@ instance TH.Quasi TcM where checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n 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.DocLoc -> TcM (Maybe String) +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 + RealSrcSpan s _ -> return s + GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan" + (pprGeneratedSrcSpanDetails) + UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" + (ppr l) + ; 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) }) } + +metaHandlersTcM :: (forall x. TcM x -> IO x) -> TH.MetaHandlers IO +metaHandlersTcM runInIO = TH.MetaHandlers { + mLiftIO = id + -- We are careful to use the TcM instance not the one for IO, since that would lead to a different error. + , mFail = \s -> runInIO $ fail @TcM s + , mNewName = \s -> runInIO $ do { u <- newUnique + ; let i = toInteger (getKey u) + ; return (TH.mkNameU s i) } + + , mReport = fmap runInIO . report + + , mLocation = runInIO location + + , mLookupName = fmap runInIO . lookupName + , mReify = runInIO . reify + , mReifyFixity = \nm -> runInIO $ lookupThName nm >>= reifyFixity + , mReifyType = runInIO . reifyTypeOfThing + , mReifyInstances = fmap runInIO . reifyInstances + , mReifyRoles = runInIO . reifyRoles + , mReifyAnnotations = runInIO . reifyAnnotations + , mReifyModule = runInIO . reifyModule + , mReifyConStrictness = \nm -> runInIO $ 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. + -- NB: extremely subtle!!! TODO: write up note + -- tryTcDiscardingErrs manipulates the reader env so we need to be careful we don't sneak in the outside env + , mRecover = \recover main -> runInIO $ tryTcDiscardingErrs (runQinTcM recover) (runQinTcM main) + + , mGetPackageRoot = runInIO $ do + dflags <- getDynFlags + return $ fromMaybe "." (workingDirectory dflags) + + , mAddDependentFile = \fp -> runInIO $ do + ref <- fmap tcg_dependent_files getGblEnv + dep_files <- readTcRef ref + writeTcRef ref (fp:dep_files) + + , mAddDependentDirectory = \dp -> runInIO $ do + ref <- fmap tcg_dependent_dirs getGblEnv + dep_dirs <- readTcRef ref + writeTcRef ref (dp:dep_dirs) + + , mAddTempFile = \suffix -> runInIO $ do + dflags <- getDynFlags + logger <- getLogger + tmpfs <- hsc_tmpfs <$> getTopEnv + liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix + + , mAddTopDecls = runInIO . addTopDecls + + , mAddForeignFilePath = \lang fp -> runInIO $ do + var <- fmap tcg_th_foreign_files getGblEnv + updTcRef var ((lang, fp) :) + + , mAddModFinalizer = \fin -> runInIO $ do + r <- liftIO $ mkRemoteRef fin + fref <- liftIO $ mkForeignRef r (freeRemoteRef r) + addModFinalizerRef fref + + , mAddCorePlugin = \plugin -> runInIO $ 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 = runInIO getQ + + , mPutQ = \x -> runInIO $ do + th_state_var <- fmap tcg_th_state getGblEnv + updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) + + , mIsExtEnabled = runInIO . xoptM + + , mExtsEnabled = runInIO $ + EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv + + , mPutDoc = fmap runInIO . putDoc + + , mGetDoc = runInIO . 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) @@ -1788,7 +1812,7 @@ runTH ty fhv = do InternalInterp -> do -- Run it in the local TcM hv <- liftIO $ wormhole interp fhv - r <- runQuasi (unsafeCoerce hv :: TH.Q a) + r <- runQinTcM (unsafeCoerce hv :: TH.Q a) return r #endif @@ -1797,7 +1821,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 -> @@ -1913,32 +1937,32 @@ 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 + NewName a -> wrapTHResult $ runQinTcM $ TH.newName a + Report b str -> wrapTHResult $ runQinTcM $ TH.report b str + LookupName b str -> wrapTHResult $ runQinTcM $ TH.lookupName b str + Reify n -> wrapTHResult $ runQinTcM $ TH.reify n + ReifyFixity n -> wrapTHResult $ runQinTcM $ TH.reifyFixity n + ReifyType n -> wrapTHResult $ runQinTcM $ TH.reifyType n + ReifyInstances n ts -> wrapTHResult $ runQinTcM $ TH.reifyInstances n ts + ReifyRoles n -> wrapTHResult $ runQinTcM $ TH.reifyRoles 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 + ReifyModule m -> wrapTHResult $ runQinTcM $ TH.reifyModule m + ReifyConStrictness nm -> wrapTHResult $ runQinTcM $ TH.reifyConStrictness nm + GetPackageRoot -> wrapTHResult $ runQinTcM $ TH.getPackageRoot + AddDependentFile f -> wrapTHResult $ runQinTcM $ TH.addDependentFile f + AddDependentDirectory d -> wrapTHResult $ runQinTcM $ TH.addDependentDirectory d + AddTempFile s -> wrapTHResult $ runQinTcM $ TH.addTempFile 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 + AddCorePlugin str -> wrapTHResult $ runQinTcM $ TH.addCorePlugin str + AddTopDecls decs -> wrapTHResult $ runQinTcM $ TH.addTopDecls decs + AddForeignFilePath lang str -> wrapTHResult $ runQinTcM $ TH.addForeignFilePath lang str + IsExtEnabled ext -> wrapTHResult $ runQinTcM $ TH.isExtEnabled ext + ExtsEnabled -> wrapTHResult $ runQinTcM $ TH.extsEnabled + PutDoc l s -> wrapTHResult $ runQinTcM $ TH.putDoc l s + GetDoc l -> wrapTHResult $ runQinTcM $ TH.getDoc l FailIfErrs -> wrapTHResult failIfErrsM _ -> panic ("handleTHMessage: unexpected message " ++ show msg) ===================================== compiler/GHC/Tc/Gen/Splice.hs-boot ===================================== @@ -42,6 +42,6 @@ runMetaT :: LHsExpr GhcTc -> TcM (LHsType GhcPs) runMetaD :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs] lookupThName_maybe :: TH.Name -> TcM (Maybe Name) -runQuasi :: TH.Q a -> TcM a +runQinTcM :: TH.Q a -> TcM a runRemoteModFinalizers :: ThModFinalizers -> TcM () finishTH :: TcM () ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs ===================================== @@ -1079,7 +1079,7 @@ withDecDoc :: String -> Q Dec -> Q Dec withDecDoc doc dec = do dec' <- dec case doc_loc dec' of - Just loc -> qAddModFinalizer $ qPutDoc loc doc + Just loc -> addModFinalizer $ putDoc loc doc Nothing -> pure () pure dec' where @@ -1128,7 +1128,7 @@ funD_doc :: Name -> [Q Clause] -> [Maybe String] -- ^ Documentation to attach to arguments -> Q Dec funD_doc nm cs mfun_doc arg_docs = do - qAddModFinalizer $ sequence_ + addModFinalizer $ sequence_ [putDoc (ArgDoc nm i) s | (i, Just s) <- zip [0..] arg_docs] let dec = funD nm cs case mfun_doc of @@ -1145,7 +1145,7 @@ dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind) -- ^ Documentation to attach to the data declaration -> Q Dec dataD_doc ctxt tc tvs ksig cons_with_docs derivs mdoc = do - qAddModFinalizer $ mapM_ docCons cons_with_docs + addModFinalizer $ mapM_ docCons cons_with_docs let dec = dataD ctxt tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) derivs maybe dec (flip withDecDoc dec) mdoc @@ -1159,7 +1159,7 @@ newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind) -- ^ Documentation to attach to the newtype declaration -> Q Dec newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do - qAddModFinalizer $ docCons con_with_docs + addModFinalizer $ docCons con_with_docs let dec = newtypeD ctxt tc tvs ksig con derivs maybe dec (flip withDecDoc dec) mdoc @@ -1172,7 +1172,7 @@ typeDataD_doc :: Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind) -- ^ Documentation to attach to the data declaration -> Q Dec typeDataD_doc tc tvs ksig cons_with_docs mdoc = do - qAddModFinalizer $ mapM_ docCons cons_with_docs + addModFinalizer $ mapM_ docCons cons_with_docs let dec = typeDataD tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) maybe dec (flip withDecDoc dec) mdoc @@ -1186,7 +1186,7 @@ dataInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -> Maybe (Q Kind) -- ^ Documentation to attach to the instance declaration -> Q Dec dataInstD_doc ctxt mb_bndrs ty ksig cons_with_docs derivs mdoc = do - qAddModFinalizer $ mapM_ docCons cons_with_docs + addModFinalizer $ mapM_ docCons cons_with_docs let dec = dataInstD ctxt mb_bndrs ty ksig (map (\(con, _, _) -> con) cons_with_docs) derivs maybe dec (flip withDecDoc dec) mdoc @@ -1202,7 +1202,7 @@ newtypeInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -- ^ Documentation to attach to the instance declaration -> Q Dec newtypeInstD_doc ctxt mb_bndrs ty ksig con_with_docs@(con, _, _) derivs mdoc = do - qAddModFinalizer $ docCons con_with_docs + addModFinalizer $ docCons con_with_docs let dec = newtypeInstD ctxt mb_bndrs ty ksig con derivs maybe dec (flip withDecDoc dec) mdoc @@ -1212,7 +1212,7 @@ patSynD_doc :: Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat -> [Maybe String] -- ^ Documentation to attach to the pattern arguments -> Q Dec patSynD_doc name args dir pat mdoc arg_docs = do - qAddModFinalizer $ sequence_ + addModFinalizer $ sequence_ [putDoc (ArgDoc name i) s | (i, Just s) <- zip [0..] arg_docs] let dec = patSynD name args dir pat maybe dec (flip withDecDoc dec) mdoc ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs ===================================== @@ -35,7 +35,7 @@ import GHC.Types (TYPE, RuntimeRep(..)) #else import GHC.Internal.Base ( Applicative(..), Functor(..), Monad(..), Monoid(..), Semigroup(..), String, - flip, id, (.), (++), + flip, id, (.), (++), ($), ) import GHC.Internal.Classes (not) import GHC.Internal.Data.Data hiding (Fixity(..)) @@ -59,145 +59,137 @@ import GHC.Internal.ForeignSrcLang import GHC.Internal.LanguageExtensions import GHC.Internal.TH.Syntax ------------------------------------------------------ --- --- The Quasi class --- ------------------------------------------------------ - -class (MonadIO m, MonadFail m) => Quasi m where - -- | Fresh names. See 'newName'. - qNewName :: String -> m Name - - ------- Error reporting and recovery ------- - -- | Report an error (True) or warning (False) - -- ...but carry on; use 'fail' to stop. See 'report'. - qReport :: Bool -> String -> m () - - -- | See 'recover'. - qRecover :: 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'. - qLookupName :: Bool -> String -> m (Maybe Name) - -- | See 'reify'. - qReify :: Name -> m Info - -- | See 'reifyFixity'. - qReifyFixity :: Name -> m (Maybe Fixity) - -- | See 'reifyType'. - qReifyType :: 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'. - qReifyInstances :: Name -> [Type] -> m [Dec] - -- | See 'reifyRoles'. - qReifyRoles :: Name -> m [Role] - -- | See 'reifyAnnotations'. - qReifyAnnotations :: Data a => AnnLookup -> m [a] - -- | See 'reifyModule'. - qReifyModule :: Module -> m ModuleInfo - -- | See 'reifyConStrictness'. - qReifyConStrictness :: Name -> m [DecidedStrictness] - - -- | See 'location'. - qLocation :: m Loc - - -- | Input/output (dangerous). See 'runIO'. - qRunIO :: IO a -> m a - qRunIO = liftIO - -- | See 'getPackageRoot'. - qGetPackageRoot :: m FilePath - - -- | See 'addDependentFile'. - qAddDependentFile :: FilePath -> m () - - -- | See 'addDependentDirectory'. - qAddDependentDirectory :: FilePath -> m () - - -- | See 'addTempFile'. - qAddTempFile :: String -> m FilePath - - -- | See 'addTopDecls'. - qAddTopDecls :: [Dec] -> m () - - -- | See 'addForeignFilePath'. - qAddForeignFilePath :: ForeignSrcLang -> String -> m () - - -- | See 'addModFinalizer'. - qAddModFinalizer :: Q () -> m () - - -- | See 'addCorePlugin'. - qAddCorePlugin :: String -> m () - - -- | See 'getQ'. - qGetQ :: Typeable a => m (Maybe a) - - -- | See 'putQ'. - qPutQ :: Typeable a => a -> m () - - -- | See 'isExtEnabled'. - qIsExtEnabled :: Extension -> m Bool - -- | See 'extsEnabled'. - qExtsEnabled :: m [Extension] - - -- | See 'putDoc'. - qPutDoc :: DocLoc -> String -> m () - -- | See 'getDoc'. - qGetDoc :: DocLoc -> m (Maybe String) +data MetaHandlers m = MetaHandlers { + mLiftIO :: forall a. IO a -> m a + , mFail :: forall a. String -> m a + -- | 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. Q a -- ^ the error handler + -> Q 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) + } ------------------------------------------------------ --- The IO instance of Quasi ------------------------------------------------------ +badIO :: String -> IO a +badIO op = do { hPutStrLn stderr ("Can't do `" ++ op ++ "' in the IO monad") + ; fail "Template Haskell failure" } --- | This instance is used only when running a Q --- computation in the IO monad, usually just to --- print the result. There is no interesting --- type environment, so reification isn't going to --- work. -instance Quasi IO where - qNewName = newNameIO - - qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) - qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) - - qLookupName _ _ = badIO "lookupName" - qReify _ = badIO "reify" - qReifyFixity _ = badIO "reifyFixity" - qReifyType _ = badIO "reifyFixity" - qReifyInstances _ _ = badIO "reifyInstances" - qReifyRoles _ = badIO "reifyRoles" - qReifyAnnotations _ = badIO "reifyAnnotations" - qReifyModule _ = badIO "reifyModule" - qReifyConStrictness _ = badIO "reifyConStrictness" - qLocation = badIO "currentLocation" - qRecover _ _ = badIO "recover" -- Maybe we could fix this? - qGetPackageRoot = badIO "getProjectRoot" - qAddDependentFile _ = badIO "addDependentFile" - qAddTempFile _ = badIO "addTempFile" - qAddTopDecls _ = badIO "addTopDecls" - qAddForeignFilePath _ _ = badIO "addForeignFilePath" - qAddModFinalizer _ = badIO "addModFinalizer" - qAddCorePlugin _ = badIO "addCorePlugin" - qGetQ = badIO "getQ" - qPutQ _ = badIO "putQ" - qIsExtEnabled _ = badIO "isExtEnabled" - qExtsEnabled = badIO "extsEnabled" - qPutDoc _ _ = badIO "putDoc" - qGetDoc _ = badIO "getDoc" - qAddDependentDirectory _ = badIO "AddDependentDirectory" +metaHandlersIO :: MetaHandlers IO +metaHandlersIO = MetaHandlers { + mLiftIO = id + , mFail = fail + , mNewName = newNameIO + , mReport = \b msg -> + if b then + hPutStrLn stderr ("Template Haskell error: " ++ msg) + else + hPutStrLn stderr ("Template Haskell error: " ++ msg) -- TODO: should this be different from above? + , mLookupName = \ _ _ -> badIO "lookupName" + , mReify = \_ -> badIO "reify" + , mReifyFixity = \_ -> badIO "reifyFixity" + , mReifyType = \_ -> badIO "reifyFixity" + , mReifyInstances = \_ _ -> badIO "reifyInstances" + , mReifyRoles = \_ -> badIO "reifyRoles" + , mReifyAnnotations = \_ -> badIO "reifyAnnotations" + , mReifyModule = \_ -> badIO "reifyModule" + , mReifyConStrictness = \_ -> badIO "reifyConStrictness" + , mLocation = badIO "currentLocation" + , mRecover = \_ _ -> badIO "recover" -- Maybe we could fix this? + , mGetPackageRoot = badIO "getProjectRoot" + , mAddDependentFile = \_ -> badIO "addDependentFile" + , mAddTempFile = \_ -> badIO "addTempFile" + , mAddTopDecls = \_ -> badIO "addTopDecls" + , mAddForeignFilePath = \_ _ -> badIO "addForeignFilePath" + , mAddModFinalizer = \_ -> badIO "addModFinalizer" + , mAddCorePlugin = \_ -> badIO "addCorePlugin" + , mGetQ = badIO "getQ" + , mPutQ = \_ -> badIO "putQ" + , mIsExtEnabled = \_ -> badIO "isExtEnabled" + , mExtsEnabled = badIO "extsEnabled" + , mPutDoc = \_ _ -> badIO "putDoc" + , mGetDoc = \_ -> badIO "getDoc" + , mAddDependentDirectory = \_ -> badIO "AddDependentDirectory" + } instance Quote IO where newName = newNameIO + + newNameIO :: String -> IO Name newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x)) ; pure (mkNameU s n) } -badIO :: String -> IO a -badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad") - ; fail "Template Haskell failure" } - -- Global variable to generate unique symbols counter :: IORef Uniq {-# NOINLINE counter #-} @@ -220,36 +212,22 @@ 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 } - --- | \"Runs\" the 'Q' monad. Normal users of Template Haskell --- should not need this function, as the splice brackets @$( ... )@ --- are the usual way of running a 'Q' computation. --- --- This function is primarily used in GHC internals, and for debugging --- splices by running them in 'IO'. --- --- Note that many functions in 'Q', such as 'reify' and other compiler --- queries, are not supported when running 'Q' in 'IO'; these operations --- 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 +newtype Q a = Q { unQ :: MetaHandlers IO -> IO a } 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 -> mFail h "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 $ \_ -> 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 @@ -319,7 +297,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 ----------------------------------------------------- -- @@ -517,7 +495,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'. @@ -532,20 +510,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 rec main = Q $ \h -> mRecover h rec main -- 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] @@ -620,7 +598,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 @@ -629,7 +607,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 @@ -637,7 +615,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 @@ -729,7 +707,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 @@ -748,20 +726,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 @@ -776,7 +754,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? -- @@ -789,7 +767,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 @@ -799,7 +777,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 -> mLiftIO 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 @@ -811,7 +789,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 @@ -830,7 +808,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 @@ -844,17 +822,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 @@ -863,7 +841,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. @@ -872,7 +850,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. -- @@ -882,7 +860,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, @@ -896,20 +874,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 @@ -928,48 +906,18 @@ 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 - qNewName = newName - qReport = report - qRecover = recover - qReify = reify - qReifyFixity = reifyFixity - qReifyType = reifyType - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness = reifyConStrictness - qLookupName = lookupName - qLocation = location - qGetPackageRoot = getPackageRoot - qAddDependentFile = addDependentFile - qAddDependentDirectory = addDependentDirectory - qAddTempFile = addTempFile - qAddTopDecls = addTopDecls - qAddForeignFilePath = addForeignFilePath - qAddModFinalizer = addModFinalizer - qAddCorePlugin = addCorePlugin - qGetQ = getQ - qPutQ = putQ - qIsExtEnabled = isExtEnabled - qExtsEnabled = extsEnabled - qPutDoc = putDoc - qGetDoc = getDoc - - ---------------------------------------------------- -- The following operations are used solely in GHC.HsToCore.Quote when -- desugaring brackets. They are not necessary for the user, who can use ===================================== libraries/ghci/GHCi/TH.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric, - TupleSections, RecordWildCards, InstanceSigs, CPP #-} + TupleSections, RecordWildCards, InstanceSigs, CPP, RankNTypes #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | @@ -164,58 +164,70 @@ ghcCmd m = GHCiQ $ \sRef -> do instance MonadIO GHCiQ where liftIO m = GHCiQ $ \_ -> m -instance TH.Quasi GHCiQ where - qNewName str = ghcCmd (NewName str) - qReport isError msg = ghcCmd (Report isError msg) - - -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice - qRecover (GHCiQ h) a = GHCiQ $ \sRef -> mask $ \unmask -> do - s <- readIORef sRef - remoteTHCall (qsPipe s) StartRecover - e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef - remoteTHCall (qsPipe s) (EndRecover (isLeft e)) - case e of - Left GHCiQException{} -> h sRef - Right r -> return r - qLookupName isType occ = ghcCmd (LookupName isType occ) - qReify name = ghcCmd (Reify name) - qReifyFixity name = ghcCmd (ReifyFixity name) - qReifyType name = ghcCmd (ReifyType name) - qReifyInstances name tys = ghcCmd (ReifyInstances name tys) - qReifyRoles name = ghcCmd (ReifyRoles name) - -- To reify annotations, we send GHC the AnnLookup and also the -- TypeRep of the thing we're looking for, to avoid needing to -- serialize irrelevant annotations. - qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a] - qReifyAnnotations lookup = +reifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a] +reifyAnnotations lookup = map (deserializeWithData . B.unpack) <$> ghcCmd (ReifyAnnotations lookup typerep) where typerep = typeOf (undefined :: a) - qReifyModule m = ghcCmd (ReifyModule m) - qReifyConStrictness name = ghcCmd (ReifyConStrictness name) - qLocation = fromMaybe noLoc . qsLocation <$> getState - qGetPackageRoot = ghcCmd GetPackageRoot - qAddDependentFile file = ghcCmd (AddDependentFile file) - qAddDependentDirectory dir = ghcCmd (AddDependentDirectory dir) - qAddTempFile suffix = ghcCmd (AddTempFile suffix) - qAddTopDecls decls = ghcCmd (AddTopDecls decls) - qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp) - qAddModFinalizer fin = GHCiQ (\_ -> mkRemoteRef fin) >>= +runQinGHCiQ :: TH.Q a -> GHCiQ a +runQinGHCiQ (TH.Q m) = GHCiQ $ \sRef -> m (metaHandlersGHCiQ (runInIO sRef)) + where + runInIO :: IORef QState -> GHCiQ a -> IO a + runInIO sRef (GHCiQ m) = m sRef + +metaHandlersGHCiQ :: (forall x. GHCiQ x -> IO x) -> TH.MetaHandlers IO +metaHandlersGHCiQ runInIO = TH.MetaHandlers { + mLiftIO = id + , mFail = runInIO . fail + , mNewName = \str -> runInIO $ ghcCmd (NewName str) + , mReport = \isError msg -> runInIO $ ghcCmd (Report isError msg) + + -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice + , mRecover = \h a -> runInIO $ GHCiQ $ \sRef -> mask $ \unmask -> do + s <- readIORef sRef + remoteTHCall (qsPipe s) StartRecover + e <- try $ unmask $ runGHCiQ (runQinGHCiQ a <* ghcCmd FailIfErrs) sRef + remoteTHCall (qsPipe s) (EndRecover (isLeft e)) + case e of + Left GHCiQException{} -> + runGHCiQ (runQinGHCiQ h) sRef + Right r -> return r + , mLookupName = \isType occ -> runInIO $ ghcCmd (LookupName isType occ) + , mReify = \name ->runInIO $ ghcCmd (Reify name) + , mReifyFixity = \name ->runInIO $ ghcCmd (ReifyFixity name) + , mReifyType = \name -> runInIO $ ghcCmd (ReifyType name) + , mReifyInstances = \name tys -> runInIO $ ghcCmd (ReifyInstances name tys) + , mReifyRoles = \name -> runInIO $ ghcCmd (ReifyRoles name) + + , mReifyAnnotations = runInIO . reifyAnnotations + , mReifyModule = \m -> runInIO $ ghcCmd (ReifyModule m) + , mReifyConStrictness = \name -> runInIO $ ghcCmd (ReifyConStrictness name) + , mLocation = runInIO $ fromMaybe noLoc . qsLocation <$> getState + , mGetPackageRoot = runInIO $ ghcCmd GetPackageRoot + , mAddDependentFile = \file -> runInIO $ ghcCmd (AddDependentFile file) + , mAddDependentDirectory = \dir -> runInIO $ ghcCmd (AddDependentDirectory dir) + , mAddTempFile = \suffix -> runInIO $ ghcCmd (AddTempFile suffix) + , mAddTopDecls = \decls -> runInIO $ ghcCmd (AddTopDecls decls) + , mAddForeignFilePath = \lang fp -> runInIO $ ghcCmd (AddForeignFilePath lang fp) + , mAddModFinalizer = \fin -> runInIO $ GHCiQ (\_ -> mkRemoteRef fin) >>= ghcCmd . AddModFinalizer - qAddCorePlugin str = ghcCmd (AddCorePlugin str) - qGetQ = do + , mAddCorePlugin = \str -> runInIO $ ghcCmd (AddCorePlugin str) + , mGetQ = runInIO $ do s <- getState let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m return $ lookup (qsMap s) - qPutQ k = GHCiQ $ \sRef -> - modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) }) - qIsExtEnabled x = ghcCmd (IsExtEnabled x) - qExtsEnabled = ghcCmd ExtsEnabled - qPutDoc l s = ghcCmd (PutDoc l s) - qGetDoc l = ghcCmd (GetDoc l) + , mPutQ = \k -> runInIO $ GHCiQ $ \sRef -> + modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) }) + , mIsExtEnabled = \x -> runInIO $ ghcCmd (IsExtEnabled x) + , mExtsEnabled = runInIO $ ghcCmd ExtsEnabled + , mPutDoc = \l s -> runInIO $ ghcCmd (PutDoc l s) + , mGetDoc = \l -> runInIO $ ghcCmd (GetDoc l) +} -- | The implementation of the 'StartTH' message: create -- a new IORef QState, and return a RemoteRef to it. @@ -235,7 +247,7 @@ runModFinalizerRefs pipe rstate qrefs = do qstateref <- localRef rstate qstate <- readIORef qstateref qstate' <- newIORef $ qstate { qsPipe = pipe } - _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate' + _ <- runGHCiQ (runQinGHCiQ $ sequence_ qs) qstate' return () -- | The implementation of the 'RunTH' message @@ -272,5 +284,5 @@ runTHQ runTHQ pipe rstate mb_loc ghciq = do qstateref <- localRef rstate modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsPipe = pipe }) - r <- runGHCiQ (TH.runQ ghciq) qstateref + r <- runGHCiQ (runQinGHCiQ ghciq) qstateref return $! LB.toStrict (runPut (put r)) ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -5,13 +5,16 @@ {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -Wno-warnings-deprecations #-} module Language.Haskell.TH.Syntax ( Quote (..), Exp (..), Match (..), Clause (..), - Q (..), + Q, + -- backwards compatibility + Language.Haskell.TH.Syntax.unQ, Pat (..), Stmt (..), Con (..), @@ -207,6 +210,8 @@ import System.FilePath import Data.Data hiding (Fixity(..)) import Data.List.NonEmpty (NonEmpty(..)) import GHC.Lexeme ( startsVarSym, startsVarId ) +import Control.Monad.IO.Class (MonadIO, liftIO) +import System.IO (hPutStrLn, stderr) -- This module completely re-exports 'GHC.Boot.TH.Syntax', -- and exports additionally functions that depend on @filepath@ or @System.IO@. @@ -499,3 +504,180 @@ reassociate the tree as necessary. -- Subsumed by the more general 'SpecialiseEP' constructor. pattern SpecialiseP :: Name -> Type -> (Maybe Inline) -> Phases -> Pragma pattern SpecialiseP nm ty inl phases = SpecialiseEP Nothing [] (SigE (VarE nm) ty) inl phases + +unQ :: Q a -> (forall m. Quasi m => m a) +unQ m = runQ m + +----------------------------------------------------- +-- +-- The Quasi class +-- +----------------------------------------------------- + +class (MonadIO m, MonadFail m) => Quasi m where + qRunQ :: Q a -> m a + -- | Fresh names. See 'newName'. + qNewName :: String -> m Name + + ------- Error reporting and recovery ------- + -- | Report an error (True) or warning (False) + -- ...but carry on; use 'fail' to stop. See 'report'. + qReport :: Bool -> String -> m () + + -- | See 'recover'. + qRecover :: 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'. + qLookupName :: Bool -> String -> m (Maybe Name) + -- | See 'reify'. + qReify :: Name -> m Info + -- | See 'reifyFixity'. + qReifyFixity :: Name -> m (Maybe Fixity) + -- | See 'reifyType'. + qReifyType :: 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'. + qReifyInstances :: Name -> [Type] -> m [Dec] + -- | See 'reifyRoles'. + qReifyRoles :: Name -> m [Role] + -- | See 'reifyAnnotations'. + qReifyAnnotations :: Data a => AnnLookup -> m [a] + -- | See 'reifyModule'. + qReifyModule :: Module -> m ModuleInfo + -- | See 'reifyConStrictness'. + qReifyConStrictness :: Name -> m [DecidedStrictness] + + -- | See 'location'. + qLocation :: m Loc + + -- | Input/output (dangerous). See 'runIO'. + qRunIO :: IO a -> m a + qRunIO = liftIO + -- | See 'getPackageRoot'. + qGetPackageRoot :: m FilePath + + -- | See 'addDependentFile'. + qAddDependentFile :: FilePath -> m () + + -- | See 'addDependentDirectory'. + qAddDependentDirectory :: FilePath -> m () + + -- | See 'addTempFile'. + qAddTempFile :: String -> m FilePath + + -- | See 'addTopDecls'. + qAddTopDecls :: [Dec] -> m () + + -- | See 'addForeignFilePath'. + qAddForeignFilePath :: ForeignSrcLang -> String -> m () + + -- | See 'addModFinalizer'. + qAddModFinalizer :: Q () -> m () + + -- | See 'addCorePlugin'. + qAddCorePlugin :: String -> m () + + -- | See 'getQ'. + qGetQ :: Typeable a => m (Maybe a) + + -- | See 'putQ'. + qPutQ :: Typeable a => a -> m () + + -- | See 'isExtEnabled'. + qIsExtEnabled :: Extension -> m Bool + -- | See 'extsEnabled'. + qExtsEnabled :: m [Extension] + + -- | See 'putDoc'. + qPutDoc :: DocLoc -> String -> m () + -- | See 'getDoc'. + qGetDoc :: DocLoc -> m (Maybe String) + +-- | \"Runs\" the 'Q' monad. Normal users of Template Haskell +-- should not need this function, as the splice brackets @$( ... )@ +-- are the usual way of running a 'Q' computation. +-- +-- This function is primarily used in GHC internals, and for debugging +-- splices by running them in 'IO'. +-- +-- Note that many functions in 'Q', such as 'reify' and other compiler +-- queries, are not supported when running 'Q' in 'IO'; these operations +-- 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 = qRunQ + +----------------------------------------------------- +-- The IO instance of Quasi +----------------------------------------------------- + +-- | This instance is used only when running a Q +-- computation in the IO monad, usually just to +-- print the result. There is no interesting +-- type environment, so reification isn't going to +-- work. +instance Quasi IO where + qRunQ (Q m) = m metaHandlersIO + qNewName = newNameIO + + qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) + qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) + + qLookupName _ _ = badIO "lookupName" + qReify _ = badIO "reify" + qReifyFixity _ = badIO "reifyFixity" + qReifyType _ = badIO "reifyFixity" + qReifyInstances _ _ = badIO "reifyInstances" + qReifyRoles _ = badIO "reifyRoles" + qReifyAnnotations _ = badIO "reifyAnnotations" + qReifyModule _ = badIO "reifyModule" + qReifyConStrictness _ = badIO "reifyConStrictness" + qLocation = badIO "currentLocation" + qRecover _ _ = badIO "recover" -- Maybe we could fix this? + qGetPackageRoot = badIO "getProjectRoot" + qAddDependentFile _ = badIO "addDependentFile" + qAddTempFile _ = badIO "addTempFile" + qAddTopDecls _ = badIO "addTopDecls" + qAddForeignFilePath _ _ = badIO "addForeignFilePath" + qAddModFinalizer _ = badIO "addModFinalizer" + qAddCorePlugin _ = badIO "addCorePlugin" + qGetQ = badIO "getQ" + qPutQ _ = badIO "putQ" + qIsExtEnabled _ = badIO "isExtEnabled" + qExtsEnabled = badIO "extsEnabled" + qPutDoc _ _ = badIO "putDoc" + qGetDoc _ = badIO "getDoc" + qAddDependentDirectory _ = badIO "AddDependentDirectory" + +instance Quasi Q where + qRunQ = id + qNewName = newName + qReport = report + qRecover = recover + qReify = reify + qReifyFixity = reifyFixity + qReifyType = reifyType + qReifyInstances = reifyInstances + qReifyRoles = reifyRoles + qReifyAnnotations = reifyAnnotations + qReifyModule = reifyModule + qReifyConStrictness = reifyConStrictness + qLookupName = lookupName + qLocation = location + qGetPackageRoot = getPackageRoot + qAddDependentFile = addDependentFile + qAddDependentDirectory = addDependentDirectory + qAddTempFile = addTempFile + qAddTopDecls = addTopDecls + qAddForeignFilePath = addForeignFilePath + qAddModFinalizer = addModFinalizer + qAddCorePlugin = addCorePlugin + qGetQ = getQ + qPutQ = putQ + qIsExtEnabled = isExtEnabled + qExtsEnabled = extsEnabled + qPutDoc = putDoc + qGetDoc = getDoc ===================================== testsuite/tests/interface-stability/template-haskell-exports.stdout ===================================== @@ -354,7 +354,6 @@ module Language.Haskell.TH where type Pred = Type type PredQ :: * type PredQ = Q Pred - type role Q nominal type Q :: * -> * newtype Q a = ... type Quote :: (* -> *) -> Constraint @@ -655,7 +654,7 @@ module Language.Haskell.TH where roleAnnotD :: forall (m :: * -> *). Quote m => Name -> [GHC.Internal.TH.Lib.Role] -> m Dec ruleVar :: forall (m :: * -> *). Quote m => Name -> m RuleBndr runIO :: forall a. GHC.Internal.Types.IO a -> Q a - runQ :: forall (m :: * -> *) a. GHC.Internal.TH.Monad.Quasi m => Q a -> m a + runQ :: forall (m :: * -> *) a. Language.Haskell.TH.Syntax.Quasi m => Q a -> m a safe :: Safety sectionL :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp sectionR :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp @@ -1703,11 +1702,11 @@ module Language.Haskell.TH.Syntax where data Pragma = InlineP Name Inline RuleMatch Phases | OpaqueP Name | SpecialiseEP (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp (GHC.Internal.Maybe.Maybe Inline) Phases | SpecialiseInstP Type | RuleP GHC.Internal.Base.String (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp | LineP GHC.Internal.Types.Int GHC.Internal.Base.String | CompleteP [Name] (GHC.Internal.Maybe.Maybe Name) | SCCP Name (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) type Pred :: * type Pred = Type - type role Q nominal type Q :: * -> * - newtype Q a = Q {unQ :: forall (m :: * -> *). Quasi m => m a} + newtype Q a = ... type Quasi :: (* -> *) -> Constraint class (GHC.Internal.Control.Monad.IO.Class.MonadIO m, GHC.Internal.Control.Monad.Fail.MonadFail m) => Quasi m where + qRunQ :: forall a. Q a -> m a qNewName :: GHC.Internal.Base.String -> m Name qReport :: GHC.Internal.Types.Bool -> GHC.Internal.Base.String -> m () qRecover :: forall a. m a -> m a -> m a @@ -1730,13 +1729,13 @@ module Language.Haskell.TH.Syntax where qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m () qAddModFinalizer :: Q () -> m () qAddCorePlugin :: GHC.Internal.Base.String -> m () - qGetQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a) - qPutQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m () + qGetQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a) + qPutQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m () qIsExtEnabled :: Extension -> m GHC.Internal.Types.Bool qExtsEnabled :: m [Extension] qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m () qGetDoc :: DocLoc -> m (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) - {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-} + {-# MINIMAL qRunQ, qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-} type Quote :: (* -> *) -> Constraint class GHC.Internal.Base.Monad m => Quote m where newName :: GHC.Internal.Base.String -> m Name @@ -1814,7 +1813,7 @@ module Language.Haskell.TH.Syntax where falseName :: Name getDoc :: DocLoc -> Q (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) getPackageRoot :: Q GHC.Internal.IO.FilePath - getQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a) + getQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a) get_cons_names :: Con -> [Name] hoistCode :: forall (m :: * -> *) (n :: * -> *) (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r). GHC.Internal.Base.Monad m => (forall x. m x -> n x) -> Code m a -> Code n a isExtEnabled :: Extension -> Q GHC.Internal.Types.Bool @@ -1861,7 +1860,7 @@ module Language.Haskell.TH.Syntax where oneName :: Name pkgString :: PkgName -> GHC.Internal.Base.String putDoc :: DocLoc -> GHC.Internal.Base.String -> Q () - putQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q () + putQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q () recover :: forall a. Q a -> Q a -> Q a reify :: Name -> Q Info reifyAnnotations :: forall a. GHC.Internal.Data.Data.Data a => AnnLookup -> Q [a] @@ -1884,6 +1883,7 @@ module Language.Haskell.TH.Syntax where trueName :: Name tupleDataName :: GHC.Internal.Types.Int -> Name tupleTypeName :: GHC.Internal.Types.Int -> Name + unQ :: forall a. Q a -> forall (m :: * -> *). Quasi m => m a unTypeCode :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => Code m a -> m Exp unTypeQ :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => m (TExp a) -> m Exp unboxedSumDataName :: SumAlt -> SumArity -> Name @@ -2289,10 +2289,10 @@ instance forall a b c d e f g. (GHC.Internal.TH.Lift.Lift a, GHC.Internal.TH.Lif instance GHC.Internal.TH.Lift.Lift (# #) -- Defined in ‘GHC.Internal.TH.Lift’ instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Char# -- Defined in ‘GHC.Internal.TH.Lift’ instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Word# -- Defined in ‘GHC.Internal.TH.Lift’ -instance GHC.Internal.TH.Monad.Quasi GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’ -instance GHC.Internal.TH.Monad.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’ instance GHC.Internal.TH.Monad.Quote GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’ instance GHC.Internal.TH.Monad.Quote GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’ instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.BndrVis -- Defined in ‘Language.Haskell.TH.Lib’ instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.Specificity -- Defined in ‘Language.Haskell.TH.Lib’ instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag () -- Defined in ‘Language.Haskell.TH.Lib’ +instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.Types.IO -- Defined in ‘Language.Haskell.TH.Syntax’ +instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘Language.Haskell.TH.Syntax’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ce1298c9fa9e9818de65297bcf6bd9a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ce1298c9fa9e9818de65297bcf6bd9a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/lifted-primitive-bytearray
by Jaro Reinders (＠jaro) 08 Jun '26

08 Jun '26

Jaro Reinders pushed new branch wip/lifted-primitive-bytearray at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/lifted-primitive-bytearray You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] EPA: Rename Transform.anchorEof to addModuleCommentOrigDeltas
by Marge Bot (＠marge-bot) 08 Jun '26

08 Jun '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: eb3bf6e7 by Alan Zimmerman at 2026-06-08T07:56:32-04:00 EPA: Rename Transform.anchorEof to addModuleCommentOrigDeltas This now matches what it actually does. - - - - - 2 changed files: - utils/check-exact/Main.hs - utils/check-exact/Transform.hs Changes: ===================================== utils/check-exact/Main.hs ===================================== @@ -646,7 +646,7 @@ addLocaLDecl3 :: Changer addLocaLDecl3 libdir top = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let - doAddLocal = replaceDecls (anchorEof lp) [parent',d2'] + doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) [parent',d2'] where lp = top (de1:d2:_) = hsDecls lp @@ -667,7 +667,7 @@ addLocaLDecl4 libdir lp = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") Right newSig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") let - doAddLocal = replaceDecls (anchorEof lp) (parent':ds) + doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) (parent':ds) where (parent:ds) = hsDecls (makeDeltaAst lp) @@ -781,7 +781,7 @@ rmDecl3 _libdir lp = do rmDecl4 :: Changer rmDecl4 _libdir lp = do let - doRmDecl = replaceDecls (anchorEof lp) [de1',sd1] + doRmDecl = replaceDecls (addModuleCommentOrigDeltas lp) [de1',sd1] where [de1] = hsDecls lp (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1a,sd2] -> ===================================== utils/check-exact/Transform.hs ===================================== @@ -65,7 +65,7 @@ module Transform , balanceComments , balanceCommentsList , balanceCommentsListA - , anchorEof + , addModuleCommentOrigDeltas -- ** Managing lists, pure functions , captureOrderBinds @@ -724,8 +724,8 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) -- --------------------------------------------------------------------- -anchorEof :: ParsedSource -> ParsedSource -anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } }) +addModuleCommentOrigDeltas :: ParsedSource -> ParsedSource +addModuleCommentOrigDeltas (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } }) where an' = addCommentOrigDeltasAnn an View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eb3bf6e7541b3d092512c49009d9809… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eb3bf6e7541b3d092512c49009d9809… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] testsuite: detect fast bignum via ghc-internal, not removed ghc-bignum
by Marge Bot (＠marge-bot) 08 Jun '26

08 Jun '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 2f3cc9ff by Simon Jakobi at 2026-06-08T07:55:49-04:00 testsuite: detect fast bignum via ghc-internal, not removed ghc-bignum The ghc-bignum package was merged into ghc-internal, so the BIGNUM_GMP probe in test.mk ran `ghc-pkg field ghc-bignum exposed-modules`, which fails with "cannot find package ghc-bignum". That error went to stderr and leaked into the captured stderr of every makefile_test, causing spurious [bad stderr] failures across the suite. The probe also silently returned empty, so config.have_fast_bignum was wrongly False even on GMP builds. Probe ghc-internal's extra-libraries for the gmp library instead: the GMP backend module is an other-module (not exposed), but GMP_LIBS adds gmp to extra-libraries only on a GMP build, so this distinguishes the backends. Redirect stderr to keep any future missing-package error off the harness's stderr. This also removes a stale comment as per suggestion from hsyl20. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 1 changed file: - testsuite/mk/test.mk Changes: ===================================== testsuite/mk/test.mk ===================================== @@ -109,9 +109,11 @@ endif HAVE_GDB := $(shell if gdb --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi) HAVE_READELF := $(shell if readelf --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi) -# we need a better way to find which backend is selected and if --check flag is -# used -BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-bignum exposed-modules | grep GMP) +# Detect whether the fast (GMP) bignum backend is in use. The GMP backend module +# in ghc-internal is hidden, so we look instead for the gmp library it links +# against: GMP_LIBS adds gmp to ghc-internal's extra-libraries only on a GMP +# build. +BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-internal extra-libraries 2>/dev/null | grep gmp) ifeq "$(filter thr, $(GhcRTSWays))" "thr" RUNTEST_OPTS += -e config.ghc_with_threaded_rts=True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2f3cc9ffbf370cf11b1fa5a253e2751… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2f3cc9ffbf370cf11b1fa5a253e2751… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/davide/hadrian_avoid_response_files_2] 2 commits: Update user guide putting response files in its own section
by David Eichmann (＠DavidEichmann) 08 Jun '26

08 Jun '26

David Eichmann pushed to branch wip/davide/hadrian_avoid_response_files_2 at Glasgow Haskell Compiler / GHC Commits: e1b514df by David Eichmann at 2026-06-08T11:24:02+01:00 Update user guide putting response files in its own section - - - - - c5c7256f by David Eichmann at 2026-06-08T12:19:22+01:00 Add changelog on hadrian's use of response files - - - - - 2 changed files: - + changelog.d/hadrian-response-files.md - docs/users_guide/using.rst Changes: ===================================== changelog.d/hadrian-response-files.md ===================================== @@ -0,0 +1,15 @@ +section: packaging +synopsis: Improved Hadrian's use of response files +issues: #27230 +mrs: !15906 !16134 +description: + Response files are files that contain command-line arguments. Hadrian uses + response files to shorten command-line lengths. This is important on Windows + where command-line lengths are limited. + + Hadrian now supports response files when invoking GHC. In order to support + manually rerunning commands issued by Hadrian, response files are no longer + deleted. Instead they are stored under `_build/rsp`. Response files are now + only used when the corresponding command-line is too long for the host + platform. This greatly reduces the use of response files and avoids excessive + file usage. Response files are overwritten on subsequent Hadrian builds. ===================================== docs/users_guide/using.rst ===================================== @@ -85,17 +85,6 @@ all files; you cannot, for example, invoke ``ghc -c -O1 Foo.hs -O2 Bar.hs`` to apply different optimisation levels to the files ``Foo.hs`` and ``Bar.hs``. -In addition to passing arguments via the command-line, arguments can be passed -via GNU-style response files. For instance, - -.. code-block:: bash - - $ cat response-file - -O1 - Hello.hs - -o Hello - $ ghc @response-file - .. note:: .. index:: @@ -118,9 +107,24 @@ via GNU-style response files. For instance, ``-fspecialise`` will not be enabled, since the ``-fno-specialise`` overrides the ``-fspecialise`` implied by ``-O1``. + +Command-line arguments in response files +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In addition to passing arguments via the command-line, arguments can be passed +via GNU-style response files. For instance, + +.. code-block:: bash + + $ cat response-file + -O1 + Hello.hs + -o Hello + $ ghc @response-file + .. _source-file-options: -Command line options in source files +Command-line options in source files ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. index:: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ea8b402afb2cc37f46aa16d84e2dad… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ea8b402afb2cc37f46aa16d84e2dad… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/supersven/cross-compiler-manual-test-jobs] 2 commits: ci: add manually-triggered full-testsuite jobs for cross-compilers
by Sven Tennie (＠supersven) 08 Jun '26

08 Jun '26

Sven Tennie pushed to branch wip/supersven/cross-compiler-manual-test-jobs at Glasgow Haskell Compiler / GHC Commits: b7a84067 by Sven Tennie at 2026-06-08T11:35:14+00:00 ci: add manually-triggered full-testsuite jobs for cross-compilers For cross-compiler targets with a real emulator (qemu, wine) add a manually-triggered companion job that downloads the bindist artifact from the corresponding build job and runs the full testsuite via a new ci.sh command test_hadrian_cross_full. Changes: - gen_ci.hs: add jobNeedsWithArtifacts field to Job (needs with artifacts:true), add crossTestJob/withCrossTestJob helpers, add withCrossTestJobAuto which activates only for real-emulator jobs by inspecting CROSS_EMULATOR in the job's variables - ci.sh: add test_hadrian_cross_full command (extract bindist, install, run hadrian test with EXTRA_HC_OPTS=-fexternal-interpreter) - jobs.yaml: regenerated Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - 96d3e23e by Sven Tennie at 2026-06-08T11:35:14+00:00 ci: symlink bootstrap GHC for test tool builds in cross test job Cross-compiler bindist only provides the cross-prefixed ghc binary. Hadrian needs a native ghc at _build/install/bin/ghc to build test support tools (check-exact, ghc-config). Symlink to bootstrap GHC which is on PATH after ci.sh setup. Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - 3 changed files: - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml Changes: ===================================== .gitlab/ci.sh ===================================== @@ -59,6 +59,7 @@ Common Modes: Hadrian build system build_hadrian Build GHC via the Hadrian build system test_hadrian Test GHC via the Hadrian build system + test_hadrian_cross_full Test cross-compiled GHC using a downloaded bindist artifact Environment variables affecting both build systems: @@ -640,6 +641,34 @@ function install_bindist() { end_section install-bindist } +function test_hadrian_cross_full() { + if [[ -z "${BIN_DIST_NAME:-}" ]]; then + fail "BIN_DIST_NAME is not set; cannot locate bindist artifact" + fi + + local instdir="$TOP/_build/install" + local test_compiler="$instdir/bin/${cross_prefix}ghc$exe" + + tar xJf "${BIN_DIST_NAME}.tar.xz" + install_bindist ghc-*/ "$instdir" + + # Cross-compiler bindist provides only the cross-prefixed ghc binary, not a + # native ghc. Hadrian needs a native ghc at this path to build test support + # tools (check-exact, ghc-config). Symlink to the bootstrap GHC from setup. + if [[ ! -e "$instdir/bin/ghc" ]]; then + ln -sf "$GHC" "$instdir/bin/ghc" + fi + + EXTRA_HC_OPTS="-fexternal-interpreter" run_hadrian \ + test \ + --summary-junit=./junit.xml \ + --test-have-intree-files \ + --test-compiler="${test_compiler}" \ + "runtest.opts+=${RUNTEST_ARGS:-}" \ + "runtest.opts+=--unexpected-output-dir=$TOP/unexpected-test-output" \ + || fail "hadrian cross full testsuite" +} + function test_hadrian() { check_msys2_deps _build/stage1/bin/ghc --version check_release_build @@ -1091,6 +1120,12 @@ case ${1:-help} in time_it "test" test_hadrian || res=$? push_perf_notes exit $res ;; + test_hadrian_cross_full) + fetch_perf_notes + res=0 + time_it "test" test_hadrian_cross_full || res=$? + push_perf_notes + exit $res ;; run_hadrian) shift; run_hadrian "$@" ;; perf_test) run_perf_test ;; abi_test) abi_test ;; ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -589,6 +589,10 @@ modifyValidateRules _ r = error $ "Applying validate rule to nightly/release job manualRule :: OnOffRules -> OnOffRules manualRule rules = rules { when = Manual } +renameRule :: String -> OnOffRules -> OnOffRules +renameRule n (OnOffRules (ValidateOnly _ rs) w) = OnOffRules (ValidateOnly n rs) w +renameRule _ r = error $ "renameRule: not a ValidateOnly rule: " ++ show (rule_set r) + -- Given 'OnOffRules', returns a list of ALL rules with their toggled status. -- For example, even if you don't explicitly disable a rule it will end up in the -- rule list with the OFF state. @@ -786,6 +790,7 @@ validateRuleString LoongArch64 = labelString "loongarch" data Job = Job { jobStage :: String , jobNeeds :: [String] + , jobNeedsWithArtifacts :: [String] , jobTags :: [String] , jobAllowFailure :: Bool , jobScript :: [String] @@ -807,7 +812,9 @@ instance ToJSON Job where [ "stage" A..= jobStage -- Convoluted to avoid download artifacts from ghci job -- https://docs.gitlab.com/ee/ci/yaml/#needsartifacts - , "needs" A..= map (\j -> object [ "job" A..= j, "artifacts" A..= False ]) jobNeeds + , "needs" A..= ( map (\j -> object [ "job" A..= j, "artifacts" A..= False ]) jobNeeds + ++ map (\j -> object [ "job" A..= j, "artifacts" A..= True ]) jobNeedsWithArtifacts + ) , "dependencies" A..= jobDependencies , "image" A..= jobDockerImage , "tags" A..= jobTags @@ -868,6 +875,7 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} } jobFlavour = mkJobFlavour buildConfig jobDependencies = [] + jobNeedsWithArtifacts = [] jobVariables = mconcat [ opsysVariables arch opsys , "TEST_ENV" =: testEnv arch opsys buildConfig @@ -1001,6 +1009,41 @@ release arch opsys bc = . ignorePerfFailures . highCompression $ j } +crossTestJob :: NamedJob Job -> NamedJob Job +crossTestJob (NamedJob buildName buildJob) = + NamedJob testName $ + buildJob + { jobNeeds = ["hadrian-ghc-in-ghci"] + , jobNeedsWithArtifacts = [buildName] + , jobDependencies = [buildName] + , jobScript = testScript (jobPlatform buildJob) + , jobRules = renameRule testName $ manualRule (jobRules buildJob) + , jobAllowFailure = True + } + where + testName = buildName ++ "-manual-testsuite" + testScript (_, opsys) = + [ "sudo chown ghc:ghc -R ." | Linux {} <- [opsys] ] ++ + [ ".gitlab/ci.sh setup" + , ".gitlab/ci.sh configure" + , ".gitlab/ci.sh test_hadrian_cross_full" + ] + +withCrossTestJob :: JobGroup Job -> [JobGroup Job] +withCrossTestJob jg@(StandardTriple (Just vj) _ _) = + [jg, StandardTriple (Just (crossTestJob vj)) Nothing Nothing] +withCrossTestJob jg = [jg] + +-- | Apply withCrossTestJob only when the job already has a real emulator configured. +-- JS and wasm jobs run their own testsuite; jobs without CROSS_EMULATOR can't run tests. +withCrossTestJobAuto :: JobGroup Job -> [JobGroup Job] +withCrossTestJobAuto jg@(StandardTriple (Just (NamedJob _ vj)) _ _) + | Just [e] <- mmlookup "CROSS_EMULATOR" (jobVariables vj) + , e /= "NOT_SET" + , e /= "js-emulator" + = withCrossTestJob jg +withCrossTestJobAuto jg = [jg] + --------------------------------------------------------------------- -- Specific job modification functions --------------------------------------------------------------------- @@ -1259,7 +1302,7 @@ alpine_aarch64 = [ ] cross_jobs :: [JobGroup Job] -cross_jobs = [ +cross_jobs = concatMap withCrossTestJobAuto [ -- x86 -> aarch64 validateBuilds Amd64 (Linux Debian13) (crossConfig "aarch64-linux-gnu" (Emulator "qemu-aarch64 -L /usr/aarch64-linux-gnu") Nothing) @@ -1439,6 +1482,8 @@ platform_mapping = Map.map go combined_result , show (name b) ] -- Explicitly selected | name a `elem` whitelist = a -- Explicitly selected | name b `elem` whitelist = b + | "-manual-testsuite" `isSuffixOf` name a = b -- prefer build job over manual test job + | "-manual-testsuite" `isSuffixOf` name b = a | otherwise = error (show (name a) ++ show (name b)) go = fmap (BindistInfo . unwords . fromJust . mmlookup "BIN_DIST_NAME" . jobVariables) ===================================== .gitlab/jobs.yaml ===================================== @@ -417,6 +417,182 @@ "WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres" } }, + "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm-manual-testsuite": { + "after_script": [ + ".gitlab/ci.sh save_cache", + ".gitlab/ci.sh save_test_output", + ".gitlab/ci.sh clean", + "cat ci_timings.txt" + ], + "allow_failure": true, + "artifacts": { + "expire_in": "2 weeks", + "paths": [ + "ghc-aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm.tar.xz", + "junit.xml", + "unexpected-test-output.tar.gz" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "aarch64-linux-deb12-wine-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [ + "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm" + ], + "image": "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-deb12-wine:$DOCKER_…", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + }, + { + "artifacts": true, + "job": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm" + } + ], + "rules": [ + { + "allow_failure": true, + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\baarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate\\+llvm-manual-testsuite(\\s|$).*/)) || (($ONLY_JOBS == null) && ((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || (($CI_MERGE_REQUEST_LABELS =~ /.*aarch64.*/) && ($CI_MERGE_REQUEST_LABELS =~ /.*Windows.*/) && ($CI_MERGE_REQUEST_LABELS =~ /.*LLVM backend.*/))))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "when": "manual" + } + ], + "script": [ + "sudo chown ghc:ghc -R .", + ".gitlab/ci.sh setup", + ".gitlab/ci.sh configure", + ".gitlab/ci.sh test_hadrian_cross_full" + ], + "stage": "full-build", + "tags": [ + "aarch64-linux" + ], + "variables": { + "AR": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-llvm-ar", + "BIGNUM_BACKEND": "native", + "BIN_DIST_NAME": "ghc-aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm", + "BUILD_FLAVOUR": "validate+llvm", + "CC": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-clang", + "CFLAGS": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt", + "CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check", + "CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt", + "CROSS_EMULATOR": "/opt/wine-arm64ec-msys2-deb12/bin/wine", + "CROSS_TARGET": "aarch64-unknown-mingw32", + "CXX": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-clang++", + "HADRIAN_ARGS": "--docs=none", + "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", + "LD": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld", + "LLVMAS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-clang", + "MergeObjsCmd": "", + "NM": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-nm", + "OBJCOPY": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-objcopy", + "OBJDUMP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-objdump", + "RANLIB": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-llvm-ranlib", + "RUNTEST_ARGS": "", + "SIZE": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-size", + "STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings", + "STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip", + "TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm", + "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt", + "WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres" + } + }, + "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate-manual-testsuite": { + "after_script": [ + ".gitlab/ci.sh save_cache", + ".gitlab/ci.sh save_test_output", + ".gitlab/ci.sh clean", + "cat ci_timings.txt" + ], + "allow_failure": true, + "artifacts": { + "expire_in": "2 weeks", + "paths": [ + "ghc-aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate.tar.xz", + "junit.xml", + "unexpected-test-output.tar.gz" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "aarch64-linux-deb12-wine-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [ + "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate" + ], + "image": "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-deb12-wine:$DOCKER_…", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + }, + { + "artifacts": true, + "job": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate" + } + ], + "rules": [ + { + "allow_failure": true, + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\baarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate-manual-testsuite(\\s|$).*/)) || (($ONLY_JOBS == null) && ((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || (($CI_MERGE_REQUEST_LABELS =~ /.*aarch64.*/) && ($CI_MERGE_REQUEST_LABELS =~ /.*Windows.*/))))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "when": "manual" + } + ], + "script": [ + "sudo chown ghc:ghc -R .", + ".gitlab/ci.sh setup", + ".gitlab/ci.sh configure", + ".gitlab/ci.sh test_hadrian_cross_full" + ], + "stage": "full-build", + "tags": [ + "aarch64-linux" + ], + "variables": { + "AR": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-llvm-ar", + "BIGNUM_BACKEND": "native", + "BIN_DIST_NAME": "ghc-aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate", + "BUILD_FLAVOUR": "validate", + "CC": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-clang", + "CFLAGS": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt", + "CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check", + "CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt", + "CROSS_EMULATOR": "/opt/wine-arm64ec-msys2-deb12/bin/wine", + "CROSS_TARGET": "aarch64-unknown-mingw32", + "CXX": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-clang++", + "HADRIAN_ARGS": "--docs=none", + "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", + "LD": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld", + "LLVMAS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-clang", + "MergeObjsCmd": "", + "NM": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-nm", + "OBJCOPY": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-objcopy", + "OBJDUMP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-objdump", + "RANLIB": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-llvm-ranlib", + "RUNTEST_ARGS": "", + "SIZE": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-size", + "STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings", + "STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip", + "TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate", + "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt", + "WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres" + } + }, "aarch64-linux-deb13-validate": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -6347,6 +6523,76 @@ "TEST_ENV": "x86_64-linux-deb13-cross_aarch64-linux-gnu-validate" } }, + "x86_64-linux-deb13-cross_aarch64-linux-gnu-validate-manual-testsuite": { + "after_script": [ + ".gitlab/ci.sh save_cache", + ".gitlab/ci.sh save_test_output", + ".gitlab/ci.sh clean", + "cat ci_timings.txt" + ], + "allow_failure": true, + "artifacts": { + "expire_in": "2 weeks", + "paths": [ + "ghc-x86_64-linux-deb13-cross_aarch64-linux-gnu-validate.tar.xz", + "junit.xml", + "unexpected-test-output.tar.gz" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "x86_64-linux-deb13-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [ + "x86_64-linux-deb13-cross_aarch64-linux-gnu-validate" + ], + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + }, + { + "artifacts": true, + "job": "x86_64-linux-deb13-cross_aarch64-linux-gnu-validate" + } + ], + "rules": [ + { + "allow_failure": true, + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-deb13-cross_aarch64-linux-gnu-validate-manual-testsuite(\\s|$).*/)) || (($ONLY_JOBS == null) && ((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/))))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "when": "manual" + } + ], + "script": [ + "sudo chown ghc:ghc -R .", + ".gitlab/ci.sh setup", + ".gitlab/ci.sh configure", + ".gitlab/ci.sh test_hadrian_cross_full" + ], + "stage": "full-build", + "tags": [ + "x86_64-linux" + ], + "variables": { + "BIGNUM_BACKEND": "gmp", + "BIN_DIST_NAME": "ghc-x86_64-linux-deb13-cross_aarch64-linux-gnu-validate", + "BUILD_FLAVOUR": "validate", + "CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check", + "CROSS_EMULATOR": "qemu-aarch64 -L /usr/aarch64-linux-gnu", + "CROSS_TARGET": "aarch64-linux-gnu", + "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", + "RUNTEST_ARGS": "", + "TEST_ENV": "x86_64-linux-deb13-cross_aarch64-linux-gnu-validate" + } + }, "x86_64-linux-deb13-int_native-validate": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -6661,6 +6907,76 @@ "TEST_ENV": "x86_64-linux-deb13-riscv-cross_riscv64-linux-gnu-validate" } }, + "x86_64-linux-deb13-riscv-cross_riscv64-linux-gnu-validate-manual-testsuite": { + "after_script": [ + ".gitlab/ci.sh save_cache", + ".gitlab/ci.sh save_test_output", + ".gitlab/ci.sh clean", + "cat ci_timings.txt" + ], + "allow_failure": true, + "artifacts": { + "expire_in": "2 weeks", + "paths": [ + "ghc-x86_64-linux-deb13-riscv-cross_riscv64-linux-gnu-validate.tar.xz", + "junit.xml", + "unexpected-test-output.tar.gz" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "x86_64-linux-deb13-riscv-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [ + "x86_64-linux-deb13-riscv-cross_riscv64-linux-gnu-validate" + ], + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13-riscv:$DOCKER_…", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + }, + { + "artifacts": true, + "job": "x86_64-linux-deb13-riscv-cross_riscv64-linux-gnu-validate" + } + ], + "rules": [ + { + "allow_failure": true, + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-deb13-riscv-cross_riscv64-linux-gnu-validate-manual-testsuite(\\s|$).*/)) || (($ONLY_JOBS == null) && ((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*RISC-V.*/)))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "when": "manual" + } + ], + "script": [ + "sudo chown ghc:ghc -R .", + ".gitlab/ci.sh setup", + ".gitlab/ci.sh configure", + ".gitlab/ci.sh test_hadrian_cross_full" + ], + "stage": "full-build", + "tags": [ + "x86_64-linux" + ], + "variables": { + "BIGNUM_BACKEND": "gmp", + "BIN_DIST_NAME": "ghc-x86_64-linux-deb13-riscv-cross_riscv64-linux-gnu-validate", + "BUILD_FLAVOUR": "validate", + "CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check", + "CROSS_EMULATOR": "qemu-riscv64 -L /usr/riscv64-linux-gnu", + "CROSS_TARGET": "riscv64-linux-gnu", + "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", + "RUNTEST_ARGS": "", + "TEST_ENV": "x86_64-linux-deb13-riscv-cross_riscv64-linux-gnu-validate" + } + }, "x86_64-linux-deb13-unreg-validate": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -7537,6 +7853,76 @@ "TEST_ENV": "x86_64-linux-ubuntu24_04-loongarch-cross_loongarch64-linux-gnu-validate" } }, + "x86_64-linux-ubuntu24_04-loongarch-cross_loongarch64-linux-gnu-validate-manual-testsuite": { + "after_script": [ + ".gitlab/ci.sh save_cache", + ".gitlab/ci.sh save_test_output", + ".gitlab/ci.sh clean", + "cat ci_timings.txt" + ], + "allow_failure": true, + "artifacts": { + "expire_in": "2 weeks", + "paths": [ + "ghc-x86_64-linux-ubuntu24_04-loongarch-cross_loongarch64-linux-gnu-validate.tar.xz", + "junit.xml", + "unexpected-test-output.tar.gz" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "x86_64-linux-ubuntu24_04-loongarch-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [ + "x86_64-linux-ubuntu24_04-loongarch-cross_loongarch64-linux-gnu-validate" + ], + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu24_04-loongarc…", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + }, + { + "artifacts": true, + "job": "x86_64-linux-ubuntu24_04-loongarch-cross_loongarch64-linux-gnu-validate" + } + ], + "rules": [ + { + "allow_failure": true, + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-ubuntu24_04-loongarch-cross_loongarch64-linux-gnu-validate-manual-testsuite(\\s|$).*/)) || (($ONLY_JOBS == null) && ((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*loongarch.*/)))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "when": "manual" + } + ], + "script": [ + "sudo chown ghc:ghc -R .", + ".gitlab/ci.sh setup", + ".gitlab/ci.sh configure", + ".gitlab/ci.sh test_hadrian_cross_full" + ], + "stage": "full-build", + "tags": [ + "x86_64-linux" + ], + "variables": { + "BIGNUM_BACKEND": "gmp", + "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu24_04-loongarch-cross_loongarch64-linux-gnu-validate", + "BUILD_FLAVOUR": "validate", + "CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check", + "CROSS_EMULATOR": "qemu-loongarch64 -L /usr/loongarch64-linux-gnu", + "CROSS_TARGET": "loongarch64-linux-gnu", + "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", + "RUNTEST_ARGS": "", + "TEST_ENV": "x86_64-linux-ubuntu24_04-loongarch-cross_loongarch64-linux-gnu-validate" + } + }, "x86_64-linux-ubuntu24_04-validate": { "after_script": [ ".gitlab/ci.sh save_cache", View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dd38245169e7890f7e486d4b77a7c4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dd38245169e7890f7e486d4b77a7c4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/ghc-9-14-building-base] Remove the `artifacts` section
by Wolfgang Jeltsch (＠jeltsch) 08 Jun '26

08 Jun '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/ghc-9-14-building-base at Glasgow Haskell Compiler / GHC Commits: 860c16bb by Wolfgang Jeltsch at 2026-06-08T14:16:52+03:00 Remove the `artifacts` section - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1163,8 +1163,6 @@ base-build-with-ghc-914: type ghcup type ghc && ghc --version type cabal - artifacts: - when: never rules: - *full-ci View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/860c16bb49a0bd3f86db88a7af3530a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/860c16bb49a0bd3f86db88a7af3530a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/dcoutts/issue-27105-stopTicker-2] 7 commits: Promote HAVE_PREEMPTION from Timer.c to OSThreads.h
by Duncan Coutts (＠dcoutts) 08 Jun '26

08 Jun '26

Duncan Coutts pushed to branch wip/dcoutts/issue-27105-stopTicker-2 at Glasgow Haskell Compiler / GHC Commits: 84cee6bb by Duncan Coutts at 2026-06-08T13:07:29+02:00 Promote HAVE_PREEMPTION from Timer.c to OSThreads.h We will want to know about HAVE_PREEMPTION in more places. HAVE_PREEMPTION tells us that we do have OS threads available, irrespective of whether THREADED is defined. In particular, HAVE_PREEMPTION is defined on all proper OSs, but not on WASM (and hyopthetically may not be true on some other platforms like micro-controllers, RTOSs, VM hypervisors etc). - - - - - 1e270fa6 by Duncan Coutts at 2026-06-08T13:07:31+02:00 Define ACQUIRE_LOCK_ALWAYS and friends Fix issue #27335 Like the atomic _ALWAYS variants, these lock actions are always defined, rather than being dependent on whether we are in the THREADED case. All the "normal" LOCK macros are defined to be no-ops when !THREADED. The use case for the _ALWAYS variants is where we are using OS threads even in the non-threaded RTS. This includes everything to do with the timer/ticker thread, which is used in the non-threaded RTS too. In particular, we will want to use this for eventlog things, because the timer thread performs eventlogging concurrently with the main capability, even in the non-threaded RTS. - - - - - 10806a8c by Duncan Coutts at 2026-06-08T13:07:31+02:00 Use ACQUIRE/RELEASE_LOCK_ALWAYS with eventBufMutex Even in the non-threaded RTS the eventBufMutex is needed by both the main capability and the timer/ticker thread, so always use the mutex. This should fix #25165 which is about the main capability and the timer thread posting events to the eventlog buffer concurrently and thereby corrupting the buffer data. - - - - - a5e2d9c6 by Duncan Coutts at 2026-06-08T13:07:31+02:00 Expose eventBufMutex in the EventLog interface/header We will need it in forkProcess to ensure we don't write to the global eventlog buffer concurrently with trying to flush eventlog buffers and do the fork(). - - - - - 7f881fdd by Duncan Coutts at 2026-06-08T13:07:31+02:00 Split flushAllCapsEventsBufs into safe and unlocked version Following the convention that unlocked versions have a trailing _ underscore in their name. This one requires the caller to hold the eventlog global buffer mutex. We will need this in forkProcess. - - - - - 45c43c44 by Duncan Coutts at 2026-06-08T13:07:31+02:00 Remove redundant use of stopTimer in setNumCapabilities Historically, the comment here was: We must stop the interval timer while we are changing the capabilities array lest handle_tick may try to context switch an old capability. See #17289. and We must disable the timer while we do this since the tick handler may call contextSwitchAllCapabilities, which may see the capabilities array as we free it. What this refers to is that historically, when changing the number of capabilities, the array of capabilities was reallocated to a new size, allocating new ones and freeing the old ones, thus invalidating all existing capbility pointers. Strangely, for good measure the code used to call stopTimer twice (hence the two similar comments above). However, since commit a3eccf06292dd666b24606251a52da2b466a9612, the capabilities array is no longer reallocated. Instead the array is allcoated once on RTS startup to the maximum size it could ever be allowed to be, and then capabilities get enabled/disabled at runtime. So the capability pointers never become invalid anymore. At worst, they may point to capabilities that are disabled. Thus we no longer need to stop the timer (twice) while we change the number of enabled capabilities. This also partially solves issue #27105, which notes that stopTimer is being used as if it were synchronous, when it is not. At least for this case, the solution is that stopTimer is not needed at all! - - - - - 55c052e2 by Duncan Coutts at 2026-06-08T13:07:31+02:00 Remove redundant use of stopTimer in forkProcess but replace it with taking the eventlog buffer lock during the fork. Fixes issue #27105 The original reason to block the timer during a fork was that historically the timer was implemented using a periodic timer signal, and the signal itself would interrupt the fork system call (returning EINTR). For large processes (where fork() takes a while) this could permanently livelock: the timer always would go off before the fork could complete, which got retried in a loop forever. The timer is no longer implemented as a unix signal, but uses threads. Thus the original problem no longer exists. The only remaining reason to block the timer tick is to prevent actions taken by the tick from interfering with the delicate process involved in fork (taking a load of locks and pausing everything). The only thing we need to do is to prevent the eventlog from being written to or flushed while the fork is taking place. To achieve this all we need to do is hold the mutex for the global eventlog buffer. This removes the last use of stopTimer that expects stopTimer to work synchronously (which it was not) and thus solves issue #27105. To be clear, we solve issue #27105 not by making stopTimer synchronous, but by eliminating the use sites that expected it to be synchronous. - - - - - 6 changed files: - rts/Capability.c - rts/Schedule.c - rts/Timer.c - rts/eventlog/EventLog.c - rts/eventlog/EventLog.h - rts/include/rts/OSThreads.h Changes: ===================================== rts/Capability.c ===================================== @@ -443,13 +443,6 @@ void moreCapabilities (uint32_t from USED_IF_THREADS, uint32_t to USED_IF_THREADS) { #if defined(THREADED_RTS) - // We must disable the timer while we do this since the tick handler may - // call contextSwitchAllCapabilities, which may see the capabilities array - // as we free it. The alternative would be to protect the capabilities - // array with a lock but this seems more expensive than necessary. - // See #17289. - stopTimer(); - if (to == 1) { // THREADED_RTS must work on builds that don't have a mutable // BaseReg (eg. unregisterised), so in this case @@ -470,8 +463,6 @@ moreCapabilities (uint32_t from USED_IF_THREADS, uint32_t to USED_IF_THREADS) } debugTrace(DEBUG_sched, "allocated %d more capabilities", to - from); - - startTimer(); #endif } ===================================== rts/Schedule.c ===================================== @@ -37,6 +37,7 @@ #include "win32/AsyncWinIO.h" #endif #include "Trace.h" +#include "eventlog/EventLog.h" #include "RaiseAsync.h" #include "Threads.h" #include "Timer.h" @@ -2100,24 +2101,31 @@ forkProcess(HsStablePtr *entry ACQUIRE_LOCK(&all_tasks_mutex); #endif - stopTimer(); // See #4074 - #if defined(TRACING) - flushAllCapsEventsBufs(); // so that child won't inherit dirty file buffers +#if defined(HAVE_PREEMPTION) + // We must hold the eventlog global mutex over the fork to prevent the + // timer thread from trying to post events. While holding the mutex we need + // to flush the eventlogs (global and per-cap) so that child won't inherit + // dirty eventlog buffers or file buffers. + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); +#endif + flushAllCapsEventsBufs_(); #endif pid = fork(); if (pid) { // parent - startTimer(); // #4074 - RELEASE_LOCK(&sched_mutex); RELEASE_LOCK(&sm_mutex); RELEASE_LOCK(&stable_ptr_mutex); RELEASE_LOCK(&stable_name_mutex); RELEASE_LOCK(&task->lock); +#if defined(TRACING) && defined(HAVE_PREEMPTION) + RELEASE_LOCK_ALWAYS(&eventBufMutex); +#endif + #if defined(THREADED_RTS) /* N.B. releaseCapability_ below may need to take all_tasks_mutex */ RELEASE_LOCK(&all_tasks_mutex); @@ -2303,12 +2311,6 @@ setNumCapabilities (uint32_t new_n_capabilities USED_IF_THREADS) cap = rts_lock(); task = cap->running_task; - - // N.B. We must stop the interval timer while we are changing the - // capabilities array lest handle_tick may try to context switch - // an old capability. See #17289. - stopTimer(); - stopAllCapabilities(&cap, task); if (new_n_capabilities < enabled_capabilities) @@ -2364,9 +2366,7 @@ setNumCapabilities (uint32_t new_n_capabilities USED_IF_THREADS) tracingAddCapabilities(n_capabilities, new_n_capabilities); #endif - // Resize the capabilities array - // NB. after this, capabilities points somewhere new. Any pointers - // of type (Capability *) are now invalid. + // Allocate and initialise the extra capabilities moreCapabilities(n_capabilities, new_n_capabilities); // Resize and update storage manager data structures @@ -2394,8 +2394,6 @@ setNumCapabilities (uint32_t new_n_capabilities USED_IF_THREADS) // Notify IO manager that the number of capabilities has changed. notifyIOManagerCapabilitiesChanged(&cap); - startTimer(); - rts_unlock(cap); #endif // THREADED_RTS ===================================== rts/Timer.c ===================================== @@ -28,11 +28,6 @@ #include "RtsSignals.h" #include "rts/EventLogWriter.h" -// See Note [No timer on wasm32] -#if !defined(wasm32_HOST_ARCH) -#define HAVE_PREEMPTION -#endif - // This global counter is used to allow multiple threads to stop the // timer temporarily with a stopTimer()/startTimer() pair. If // timer_enabled == 0 timer is enabled ===================================== rts/eventlog/EventLog.c ===================================== @@ -129,8 +129,11 @@ typedef struct _EventsBuf { static EventsBuf *capEventBuf; // one EventsBuf for each Capability static EventsBuf eventBuf; // an EventsBuf not associated with any Capability -#if defined(THREADED_RTS) -static Mutex eventBufMutex; // protected by this mutex +#if defined(HAVE_PREEMPTION) +// Note that this mutex is used even in the non-threaded RTS, since the timer +// thread posts events and flushes. So _all_ uses of this mutex must use +// ACQUIRE_LOCK_ALWAYS/RELEASE_LOCK_ALWAYS. +Mutex eventBufMutex; // protects eventBuf above #endif // Event type @@ -393,8 +396,10 @@ initEventLogging(void) moreCapEventBufs(0, get_n_capabilities()); initEventsBuf(&eventBuf, EVENT_LOG_SIZE, (EventCapNo)(-1)); -#if defined(THREADED_RTS) +#if defined(HAVE_PREEMPTION) initMutex(&eventBufMutex); +#endif +#if defined(THREADED_RTS) initMutex(&state_change_mutex); #endif } @@ -416,7 +421,7 @@ startEventLogging_(void) { initEventLogWriter(); - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); postHeaderEvents(); /* @@ -425,7 +430,7 @@ startEventLogging_(void) */ printAndClearEventBuf(&eventBuf); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); return true; } @@ -495,7 +500,7 @@ endEventLogging(void) flushEventLog_(NULL); - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); // Mark end of events (data). postEventTypeNum(&eventBuf, EVENT_DATA_END); @@ -503,7 +508,7 @@ endEventLogging(void) // Flush the end of data marker. printAndClearEventBuf(&eventBuf); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); stopEventLogWriter(); event_log_writer = NULL; @@ -666,7 +671,7 @@ void postCapEvent (EventTypeNum tag, EventCapNo capno) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, tag); postEventHeader(&eventBuf, tag); @@ -685,14 +690,14 @@ postCapEvent (EventTypeNum tag, barf("postCapEvent: unknown event tag %d", tag); } - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postCapsetEvent (EventTypeNum tag, EventCapsetID capset, StgWord info) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, tag); postEventHeader(&eventBuf, tag); @@ -726,7 +731,7 @@ void postCapsetEvent (EventTypeNum tag, barf("postCapsetEvent: unknown event tag %d", tag); } - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postCapsetStrEvent (EventTypeNum tag, @@ -740,14 +745,14 @@ void postCapsetStrEvent (EventTypeNum tag, return; } - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); if (!hasRoomForVariableEvent(&eventBuf, size)){ printAndClearEventBuf(&eventBuf); if (!hasRoomForVariableEvent(&eventBuf, size)){ errorBelch("Event size exceeds buffer size, bail out"); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); return; } } @@ -758,7 +763,7 @@ void postCapsetStrEvent (EventTypeNum tag, postBuf(&eventBuf, (StgWord8*) msg, strsize); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postCapsetVecEvent (EventTypeNum tag, @@ -783,14 +788,14 @@ void postCapsetVecEvent (EventTypeNum tag, } } - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); if (!hasRoomForVariableEvent(&eventBuf, size)){ printAndClearEventBuf(&eventBuf); if(!hasRoomForVariableEvent(&eventBuf, size)){ errorBelch("Event size exceeds buffer size, bail out"); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); return; } } @@ -804,7 +809,7 @@ void postCapsetVecEvent (EventTypeNum tag, postBuf(&eventBuf, (StgWord8*) argv[i], 1 + strlen(argv[i])); } - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postWallClockTime (EventCapsetID capset) @@ -813,7 +818,7 @@ void postWallClockTime (EventCapsetID capset) StgWord64 sec; StgWord32 nsec; - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); /* The EVENT_WALL_CLOCK_TIME event is intended to allow programs reading the eventlog to match up the event timestamps with wall @@ -846,7 +851,7 @@ void postWallClockTime (EventCapsetID capset) postWord64(&eventBuf, sec); postWord32(&eventBuf, nsec); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } /* @@ -885,7 +890,7 @@ void postEventHeapInfo (EventCapsetID heap_capset, W_ mblockSize, W_ blockSize) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_HEAP_INFO_GHC); postEventHeader(&eventBuf, EVENT_HEAP_INFO_GHC); @@ -899,7 +904,7 @@ void postEventHeapInfo (EventCapsetID heap_capset, postWord64(&eventBuf, mblockSize); postWord64(&eventBuf, blockSize); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postEventGcStats (Capability *cap, @@ -952,7 +957,7 @@ void postTaskCreateEvent (EventTaskId taskId, EventCapNo capno, EventKernelThreadId tid) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_TASK_CREATE); postEventHeader(&eventBuf, EVENT_TASK_CREATE); @@ -961,14 +966,14 @@ void postTaskCreateEvent (EventTaskId taskId, postCapNo(&eventBuf, capno); postKernelThreadId(&eventBuf, tid); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postTaskMigrateEvent (EventTaskId taskId, EventCapNo capno, EventCapNo new_capno) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_TASK_MIGRATE); postEventHeader(&eventBuf, EVENT_TASK_MIGRATE); @@ -977,28 +982,28 @@ void postTaskMigrateEvent (EventTaskId taskId, postCapNo(&eventBuf, capno); postCapNo(&eventBuf, new_capno); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postTaskDeleteEvent (EventTaskId taskId) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_TASK_DELETE); postEventHeader(&eventBuf, EVENT_TASK_DELETE); /* EVENT_TASK_DELETE (taskID) */ postTaskId(&eventBuf, taskId); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postEventNoCap (EventTypeNum tag) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, tag); postEventHeader(&eventBuf, tag); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void @@ -1042,9 +1047,9 @@ void postLogMsg(EventsBuf *eb, EventTypeNum type, char *msg, va_list ap) void postMsg(char *msg, va_list ap) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); postLogMsg(&eventBuf, EVENT_LOG_MSG, msg, ap); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postCapMsg(Capability *cap, char *msg, va_list ap) @@ -1138,32 +1143,32 @@ void postConcUpdRemSetFlush(Capability *cap) void postConcMarkEnd(StgWord32 marked_obj_count) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_CONC_MARK_END); postEventHeader(&eventBuf, EVENT_CONC_MARK_END); postWord32(&eventBuf, marked_obj_count); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postNonmovingHeapCensus(uint16_t blk_size, const struct NonmovingAllocCensus *census) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); postEventHeader(&eventBuf, EVENT_NONMOVING_HEAP_CENSUS); postWord16(&eventBuf, blk_size); postWord32(&eventBuf, census->n_active_segs); postWord32(&eventBuf, census->n_filled_segs); postWord32(&eventBuf, census->n_live_blocks); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postNonmovingPrunedSegments(uint32_t pruned_segments, uint32_t free_segments) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); postEventHeader(&eventBuf, EVENT_NONMOVING_PRUNED_SEGMENTS); postWord32(&eventBuf, pruned_segments); postWord32(&eventBuf, free_segments); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void closeBlockMarker (EventsBuf *ebuf) @@ -1224,7 +1229,7 @@ static HeapProfBreakdown getHeapProfBreakdown(void) void postHeapProfBegin(void) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); PROFILING_FLAGS *flags = &RtsFlags.ProfFlags; StgWord modSelector_len = flags->modSelector ? strlen(flags->modSelector) : 0; @@ -1258,42 +1263,42 @@ void postHeapProfBegin(void) postStringLen(&eventBuf, flags->ccsSelector, ccsSelector_len); postStringLen(&eventBuf, flags->retainerSelector, retainerSelector_len); postStringLen(&eventBuf, flags->bioSelector, bioSelector_len); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postHeapProfSampleBegin(StgInt era) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_HEAP_PROF_SAMPLE_BEGIN); postEventHeader(&eventBuf, EVENT_HEAP_PROF_SAMPLE_BEGIN); postWord64(&eventBuf, era); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postHeapBioProfSampleBegin(StgInt era, StgWord64 time) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_HEAP_BIO_PROF_SAMPLE_BEGIN); postEventHeader(&eventBuf, EVENT_HEAP_BIO_PROF_SAMPLE_BEGIN); postWord64(&eventBuf, era); postWord64(&eventBuf, time); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postHeapProfSampleEnd(StgInt era) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_HEAP_PROF_SAMPLE_END); postEventHeader(&eventBuf, EVENT_HEAP_PROF_SAMPLE_END); postWord64(&eventBuf, era); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postHeapProfSampleString(const char *label, StgWord64 residency) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); StgWord label_len = strlen(label); StgWord len = 1+8+label_len+1; CHECK(!ensureRoomForVariableEvent(&eventBuf, len)); @@ -1303,7 +1308,7 @@ void postHeapProfSampleString(const char *label, postWord8(&eventBuf, 0); postWord64(&eventBuf, residency); postStringLen(&eventBuf, label, label_len); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } #if defined(PROFILING) @@ -1313,7 +1318,7 @@ void postHeapProfCostCentre(StgWord32 ccID, const char *srcloc, StgBool is_caf) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); StgWord label_len = strlen(label); StgWord module_len = strlen(module); StgWord srcloc_len = strlen(srcloc); @@ -1326,13 +1331,13 @@ void postHeapProfCostCentre(StgWord32 ccID, postStringLen(&eventBuf, module, module_len); postStringLen(&eventBuf, srcloc, srcloc_len); postWord8(&eventBuf, is_caf); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void postHeapProfSampleCostCentre(CostCentreStack *stack, StgWord64 residency) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); StgWord depth = 0; CostCentreStack *ccs; for (ccs = stack; ccs != NULL && ccs != CCS_MAIN; ccs = ccs->prevStack) @@ -1351,7 +1356,7 @@ void postHeapProfSampleCostCentre(CostCentreStack *stack, depth>0 && ccs != NULL && ccs != CCS_MAIN; ccs = ccs->prevStack, depth--) postWord32(&eventBuf, ccs->cc->ccID); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } @@ -1359,7 +1364,7 @@ void postProfSampleCostCentre(Capability *cap, CostCentreStack *stack, StgWord64 tick) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); StgWord depth = 0; CostCentreStack *ccs; for (ccs = stack; ccs != NULL && ccs != CCS_MAIN; ccs = ccs->prevStack) @@ -1377,7 +1382,7 @@ void postProfSampleCostCentre(Capability *cap, depth>0 && ccs != NULL && ccs != CCS_MAIN; ccs = ccs->prevStack, depth--) postWord32(&eventBuf, ccs->cc->ccID); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } // This event is output at the start of profiling so the tick interval can @@ -1385,11 +1390,11 @@ void postProfSampleCostCentre(Capability *cap, // can be calculated from how many samples there are. void postProfBegin(void) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); postEventHeader(&eventBuf, EVENT_PROF_BEGIN); // The interval that each tick was sampled, in nanoseconds postWord64(&eventBuf, TimeToNS(RtsFlags.MiscFlags.tickInterval)); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } #endif /* PROFILING */ @@ -1415,11 +1420,11 @@ static void postTickyCounterDef(EventsBuf *eb, StgEntCounter *p) void postTickyCounterDefs(StgEntCounter *counters) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); for (StgEntCounter *p = counters; p != NULL; p = p->link) { postTickyCounterDef(&eventBuf, p); } - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } static void postTickyCounterSample(EventsBuf *eb, StgEntCounter *p) @@ -1443,13 +1448,13 @@ static void postTickyCounterSample(EventsBuf *eb, StgEntCounter *p) void postTickyCounterSamples(StgEntCounter *counters) { - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); ensureRoomForEvent(&eventBuf, EVENT_TICKY_COUNTER_SAMPLE); postEventHeader(&eventBuf, EVENT_TICKY_COUNTER_BEGIN_SAMPLE); for (StgEntCounter *p = counters; p != NULL; p = p->link) { postTickyCounterSample(&eventBuf, p); } - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } #endif /* TICKY_TICKY */ void postIPE(const InfoProvEnt *ipe) @@ -1459,7 +1464,7 @@ void postIPE(const InfoProvEnt *ipe) // See Note [Maximum event length]. const StgWord MAX_IPE_STRING_LEN = 65535; - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); StgWord table_name_len = MIN(strlen(ipe->prov.table_name), MAX_IPE_STRING_LEN); StgWord closure_desc_len = MIN(strlen(closure_desc_buf), MAX_IPE_STRING_LEN); StgWord ty_desc_len = MIN(strlen(ipe->prov.ty_desc), MAX_IPE_STRING_LEN); @@ -1489,7 +1494,7 @@ void postIPE(const InfoProvEnt *ipe) postBuf(&eventBuf, &colon, 1); postStringLen(&eventBuf, ipe->prov.src_span, src_span_len); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); } void printAndClearEventBuf (EventsBuf *ebuf) @@ -1601,14 +1606,21 @@ void flushLocalEventsBuf(Capability *cap) // Flush all capabilities' event buffers when we already hold all capabilities. // Used during forkProcess. void flushAllCapsEventsBufs(void) +{ + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); + flushAllCapsEventsBufs_(); + RELEASE_LOCK_ALWAYS(&eventBufMutex); +} + +// Unsafe version that does not acquire/release eventBufMutex. You must +// hold the eventBufMutex, which you must acquire with ACQUIRE_LOCK_ALWAYS! +void flushAllCapsEventsBufs_(void) { if (!event_log_writer) { return; } - ACQUIRE_LOCK(&eventBufMutex); printAndClearEventBuf(&eventBuf); - RELEASE_LOCK(&eventBufMutex); for (unsigned int i=0; i < getNumCapabilities(); i++) { flushLocalEventsBuf(getCapability(i)); @@ -1641,9 +1653,9 @@ static void flushEventLog_(Capability **cap USED_IF_THREADS) return; } - ACQUIRE_LOCK(&eventBufMutex); + ACQUIRE_LOCK_ALWAYS(&eventBufMutex); printAndClearEventBuf(&eventBuf); - RELEASE_LOCK(&eventBufMutex); + RELEASE_LOCK_ALWAYS(&eventBufMutex); #if defined(THREADED_RTS) Task *task = newBoundTask(); ===================================== rts/eventlog/EventLog.h ===================================== @@ -18,6 +18,13 @@ #if defined(TRACING) extern bool eventlog_enabled; +#if defined(HAVE_PREEMPTION) +// Avoid using this mutex directly if at all possible. It is needed in the +// implementation of forkProcess. +// +// All uses of this mutex must use ACQUIRE_LOCK_ALWAYS/RELEASE_LOCK_ALWAYS. +extern Mutex eventBufMutex; +#endif void initEventLogging(void); void restartEventLogging(void); @@ -27,6 +34,7 @@ void abortEventLogging(void); // #4512 - after fork child needs to abort void moreCapEventBufs (uint32_t from, uint32_t to); void flushLocalEventsBuf(Capability *cap); void flushAllCapsEventsBufs(void); +void flushAllCapsEventsBufs_(void); void flushAllEventsBufs(Capability *cap); typedef void (*EventlogInitPost)(void); ===================================== rts/include/rts/OSThreads.h ===================================== @@ -14,6 +14,46 @@ #pragma once +/* Note [Threads and preemption] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + All full-fat OSs that GHC works on have OS threads, and we use them even in + the non-threaded RTS for a few features: + * Haskell thread preemption; + * sample-based profiling; + * idle GC; + * periodic eventlog flushing. + + We use defined(HAVE_PREEMPTION) to decide if these features are implemented + via OS threads. + + On platforms like WASM/js we do not have OS threads in any conventional + sense, and the features above are either not available or are implemented + differently. See Note [No timer on wasm32]. + + In future if GHC is ported to platforms like bare-metal micro-controllers, + RTOSs or to run directly under hypervisors then such platforms may also not + have threads available and they should not define HAVE_PREEMPTION here. Or + for some micro-controller RTOSs like Zeypher one may have a choice about + whether to use threads or not (at a size cost). Here would be the right + place to control whether the feature list above is supported. + */ +#if defined(wasm32_HOST_ARCH) + // See Note [No timer on wasm32] + // To confuse matters, WASM _does_ have pthread.h but it doesnt work. +#elif defined(HAVE_PTHREAD_H) || defined(HAVE_WINDOWS_H) +#define HAVE_PREEMPTION +#else +#error Decide if this platform has threads and pre-emption or not. +#endif +// And JS does all of this differently, without using this bit of the RTS. + +// Configuration sanity check +#if defined(THREADED_RTS) && !defined(HAVE_PREEMPTION) +//TODO we would like to be able to assert this: +// #error Configuration error: THREADED_RTS should imply HAVE_PREEMPTION +// however at the moment we cannot due to issue #27346. +#endif + #if defined(HAVE_PTHREAD_H) && !defined(mingw32_HOST_OS) #if defined(CMINUSMINUS) @@ -210,9 +250,29 @@ extern bool timedWaitCondition ( Condition* pCond, Mutex* pMut, Time timeout) // // Mutexes // +// Even in the non-threaded RTS we use threads and mutexes! In particular the +// timer/ticker is implemented using a thread. And using threads needs locks. +// In particular we need locks for the data shared between the timer/ticker +// thread and the thread running the main capability. +#if defined(HAVE_PREEMPTION) extern void initMutex ( Mutex* pMut ); extern void closeMutex ( Mutex* pMut ); +// The "always" variants do locking in the threaded and non-threaded RTS. +// The normal variants below are no-ops in the non-threaded RTS. +#define ACQUIRE_LOCK_ALWAYS(l) OS_ACQUIRE_LOCK(l) +#define TRY_ACQUIRE_LOCK_ALWAYS(l) OS_TRY_ACQUIRE_LOCK(l) +#define RELEASE_LOCK_ALWAYS(l) OS_RELEASE_LOCK(l) +#define ASSERT_LOCK_HELD_ALWAYS(l) OS_ASSERT_LOCK_HELD(l) +#else +// And just to be a bit confusing, the always variants are still no-ops when we +// do not HAVE_PREEMPTION, since then we don't have threads or mutexes at all. +#define ACQUIRE_LOCK_ALWAYS(l) +#define TRY_ACQUIRE_LOCK_ALWAYS(l) 0 +#define RELEASE_LOCK_ALWAYS(l) +#define ASSERT_LOCK_HELD_ALWAYS(l) +#endif + // Processors and affinity void setThreadAffinity (uint32_t n, uint32_t m); void setThreadNode (uint32_t node); @@ -228,6 +288,7 @@ void releaseThreadNode (void); #else +// No-ops in the non-threaded RTS. See also the _ALWAYS variants above. #define ACQUIRE_LOCK(l) #define TRY_ACQUIRE_LOCK(l) 0 #define RELEASE_LOCK(l) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7d07b187d005728e16062432c01b55… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7d07b187d005728e16062432c01b55… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/jeltsch/ghc-9-14-building-base
by Wolfgang Jeltsch (＠jeltsch) 08 Jun '26

08 Jun '26

Wolfgang Jeltsch pushed new branch wip/jeltsch/ghc-9-14-building-base at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/jeltsch/ghc-9-14-building-base You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/T27296-stable-simpl] 2 commits: Add -dstable-core-dump-order for stable Core dump ordering (#27296)
by Simon Jakobi (＠sjakobi2) 08 Jun '26

08 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/T27296-stable-simpl at Glasgow Haskell Compiler / GHC Commits: b63f205e by Simon Jakobi at 2026-06-08T10:04:50+02:00 Add -dstable-core-dump-order for stable Core dump ordering (#27296) The order of top-level bindings in Core dumps (-ddump-simpl etc.) is the compiler's internal processing order, which is sensitive to Uniques. Uniques can shift whenever an unrelated upstream module changes, so the bindings get re-ordered and a textual diff of two dumps fails to line up the real changes. This adds an opt-in flag -dstable-core-dump-order that reorders the top-level bindings of Core dumps routed through dumpPassResult into a stable, unique-independent order: by source location, then a $-rank so a derived $w/$s binder sorts before its origin (mirroring GHC's default dependency order, where the wrapper calls the worker), then the OccName. Workers and specialisations inherit their origin's source span, so they cluster next to the binding they come from; anonymous floats (noSrcSpan) sort to the end; Rec groups are kept intact. Only top-level bindings are reordered; nested bindings are left as-is. The default order is retained as it is useful when debugging the compiler itself. The ordering is unique-independent, so two dumps line up across rebuilds. See Note [Stable Core dump order] in GHC.Core.Ppr. Adds test T27296, a small Data.Map-style module whose binders GHC emits in a non-source order by default, asserting they come out stably ordered under the flag. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 5a4d2cda by Simon Jakobi at 2026-06-08T12:21:30+02:00 WIP: stabilise anonymous float ordering in untidied Core dumps Anonymous floats are all built with OccName "lvl" and noSrcSpan (newLvlVar), so the source-span/name sort key is identical for every one of them; sortOn then falls back to the unique-driven input order -- the very churn -dstable-core-dump-order is meant to remove. (Tidied dumps like -ddump-simpl are unaffected, as tidy gives the floats distinct names lvl, lvl1, ...) Add a content-based, unique-independent tie-break (rhsKey): the floated literal, if any, then the RHS size statistics. Laziness means it is computed only when the earlier key components tie. Add test T27296b pinning the float ordering in an untidied -ddump-float-out dump. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 14 changed files: - + changelog.d/stable-core-dump-order-27296 - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Utils/Outputable.hs - docs/users_guide/debugging.rst - testsuite/tests/simplCore/should_compile/Makefile - + testsuite/tests/simplCore/should_compile/T27296.hs - + testsuite/tests/simplCore/should_compile/T27296.stdout - + testsuite/tests/simplCore/should_compile/T27296b.hs - + testsuite/tests/simplCore/should_compile/T27296b.stderr - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== changelog.d/stable-core-dump-order-27296 ===================================== @@ -0,0 +1,4 @@ +section: compiler +synopsis: Add :ghc-flag:`-dstable-core-dump-order`, a debugging flag that prints top-level Core bindings in a stable, source-location-based order that does not depend on uniques, making intermediate-compiler dumps (e.g. with :ghc-flag:`-ddump-simpl` or :ghc-flag:`-dverbose-core2core`) easier to diff. This affects only the compiler's intermediate output; it does not change generated code. +issues: #27296 +mrs: !16143 ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -327,12 +327,17 @@ dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr extra_info binds where size_doc = sep [text "Result size of" <+> text hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] + -- See Note [Stable Core dump order] in GHC.Core.Ppr + binds' | sdocStableCoreDumpOrder (log_default_dump_context (logFlags logger)) + = sortCoreBindingsForDump binds + | otherwise = binds + dump_doc = vcat [ nest 2 extra_info , size_doc , blankLine , if dump_core_sizes - then pprCoreBindingsWithSize binds - else pprCoreBindings binds + then pprCoreBindingsWithSize binds' + else pprCoreBindings binds' , ppUnless (null rules) pp_rules ] pp_rules = vcat [ blankLine , text "------ Local rules for imported ids --------" ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -19,6 +19,7 @@ module GHC.Core.Ppr ( pprCoreExpr, pprParendExpr, pprCoreBinding, pprCoreBindings, pprCoreAlt, pprCoreBindingWithSize, pprCoreBindingsWithSize, + sortCoreBindingsForDump, pprCoreBinder, pprCoreBinders, pprId, pprIds, pprRule, pprRules, pprOptCo, pprOcc, pprOccWithTick @@ -27,10 +28,10 @@ module GHC.Core.Ppr ( import GHC.Prelude import GHC.Core -import GHC.Core.Stats (exprStats) +import GHC.Core.Stats (exprStats, CoreStats(..)) import GHC.Types.Fixity (LexicalFixity(..)) -import GHC.Types.Literal( pprLiteral ) -import GHC.Types.Name( pprInfixName, pprPrefixName ) +import GHC.Types.Literal( pprLiteral, Literal ) +import GHC.Types.Name( pprInfixName, pprPrefixName, getOccString, getSrcSpan ) import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info @@ -44,9 +45,13 @@ import GHC.Core.Coercion import GHC.Types.Basic import GHC.Utils.Misc import GHC.Utils.Outputable -import GHC.Types.SrcLoc ( pprUserRealSpan ) +import GHC.Utils.Panic (panic) +import GHC.Types.SrcLoc ( SrcSpan(..), srcSpanStartLine, srcSpanStartCol + , pprUserRealSpan ) import GHC.Types.Tickish +import Data.List ( sortOn ) + {- ************************************************************************ * * @@ -71,6 +76,119 @@ pprCoreBindingWithSize :: CoreBind -> SDoc pprCoreBindingsWithSize = pprTopBinds sizeAnn pprCoreBindingWithSize = pprTopBind sizeAnn +{- Note [Stable Core dump order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The order of top-level bindings in a Core dump (-ddump-simpl etc.) is the +compiler's internal processing order, which is sensitive to Uniques. Uniques +can shift whenever an unrelated upstream module changes, so the bindings get +re-ordered and a textual diff of two dumps fails to line up the real changes +(#27296). + +With -dstable-core-dump-order we reorder the top-level bindings at dump time into +a stable order. 'sortCoreBindingsForDump' sorts by a key that is *independent of +Uniques*, so two dumps line up across rebuilds. The sort key is: + + 1. the binder's source span (real spans in source order; noSrcSpan last). + Workers and specialisations inherit their origin's source span (see + 'mkWorkerId' and 'newSpecIdSM'), so they cluster next to the binding they + come from. + 2. a "$-rank" so that within one source span the compiler-derived binders sort + *before* the origin they come from (e.g. @$wfoo@ before @foo@), mirroring + GHC's default dependency order (the wrapper calls the worker, so the worker + comes first; specialisations likewise precede their origin). We rank by + whether the OccName *contains* a '$', which marks a derived binder: a worker + is @$wfoo@, but a call-site specialisation is tidied to @bar_$sfoo@ (no + leading '$'), so a leading-'$' test would miss it. + 3. the OccName string, as a lexical, deterministic tie-break. + 4. a content-based tie-break on the right-hand side ('rhsKey'): the floated + literal, if any, then the RHS size statistics. This matters for the + anonymous floats: 'newLvlVar' builds them all with OccName "lvl" and + noSrcSpan, so keys 1-3 are identical and, without this, their order would + fall back to the Unique-driven input order -- exactly the churn we set out + to remove. (In tidied dumps like -ddump-simpl the floats already have + distinct names lvl, lvl1, ...; this tie-break additionally stabilises the + untidied dumps -ddump-simpl-iterations, -dverbose-core2core etc.) It is + also Unique-independent, and laziness means it is only computed when keys + 1-3 tie. + +Recursive groups are never split: a 'Rec' is one 'CoreBind', placed as a unit by +its earliest-source member, with its members sorted by the same key. + +Only *top-level* bindings (and the members of a top-level 'Rec') are reordered. +Bindings nested inside a right-hand side (a 'let'/'letrec' within an expression) +are left in their original order: their position in the dump is fixed by the +surrounding expression rather than chosen by a Unique-keyed sort, so they don't +suffer the cross-module churn this flag addresses. + +-dstable-core-dump-order is opt-in; the default order is retained because it is +useful for debugging the compiler itself. +-} + +-- | The sort key for one top-level binder. The trailing 'RhsKey' is a +-- content-based tiebreak; thanks to laziness it is forced only when two binders +-- agree on everything before it. See Note [Stable Core dump order]. +type DumpSortKey = + ( Int -- ^ source-span bucket: @0@ = real span, @1@ = 'noSrcSpan' (sorts last) + , Int -- ^ source-span start line + , Int -- ^ source-span start column + , Int -- ^ @$@-rank: @0@ = derived (@$w@\/@$s@) binder, @1@ = its origin + , String -- ^ the 'OccName' string, a lexical tiebreak + , RhsKey -- ^ content-based tiebreak (see 'rhsKey') + ) + +-- | Reorder a 'CoreProgram' into a stable, source-location-driven order for +-- dumping. See Note [Stable Core dump order]. Used by 'dumpPassResult' when +-- -dstable-core-dump-order is enabled. +sortCoreBindingsForDump :: CoreProgram -> CoreProgram +sortCoreBindingsForDump = sortOn bindKey . map sortRecMembers + where + sortRecMembers (Rec prs) = Rec (sortOn (uncurry elemKey) prs) + sortRecMembers b = b + + -- 'sortRecMembers' runs first, so a 'Rec' is already sorted by 'elemKey' + -- when 'bindKey' sees it; its first member is therefore the minimum key. + bindKey :: CoreBind -> DumpSortKey + bindKey (NonRec b rhs) = elemKey b rhs + bindKey (Rec ((b,rhs):_)) = elemKey b rhs + bindKey (Rec []) = panic "sortCoreBindingsForDump: empty Rec" + + elemKey :: CoreBndr -> CoreExpr -> DumpSortKey + elemKey b rhs = (bucket, line, col, dollar_rank, s, rhsKey rhs) + where + s = getOccString b + (bucket, line, col) = case getSrcSpan b of + RealSrcSpan rs _ -> (0, srcSpanStartLine rs, srcSpanStartCol rs) + _ -> (1, 0, 0) -- noSrcSpan: sort last + -- A '$' anywhere in a tidied top-level OccName marks a compiler-derived + -- binder ($wfoo, but also call-site specialisations tidied to + -- bar_$sfoo); rank those before their origin within a shared source span, + -- mirroring GHC's default dependency order (the wrapper calls the worker, + -- so the worker comes first). + dollar_rank | '$' `elem` s = 0 + | otherwise = 1 + +-- | A cheap, Unique-independent tiebreak on a binder's right-hand side, used to +-- order binders that are otherwise indistinguishable -- in practice the +-- anonymous floats, which all share OccName \"lvl\" and 'noSrcSpan' (see +-- 'GHC.Core.Opt.SetLevels.newLvlVar'). It pairs the floated literal (if any, +-- looking through the @I#@-style box and casts/ticks) with the RHS size +-- statistics; both are independent of Uniques, so the order is stable even +-- without -dsuppress-uniques. See Note [Stable Core dump order]. +type RhsKey = + ( Maybe Literal -- ^ the floated literal, if any ('Nothing' sorts first) + , (Int, Int, Int, Int, Int) -- ^ 'exprStats' counts: terms, types, coercions, value binds, join binds + ) + +rhsKey :: CoreExpr -> RhsKey +rhsKey rhs = (litOf rhs, statsTuple (exprStats rhs)) + where + statsTuple (CS tm ty co vb jb) = (tm, ty, co, vb, jb) + litOf (Lit l) = Just l + litOf (App f a) = case a of { Lit l -> Just l; _ -> litOf f } + litOf (Cast e _) = litOf e + litOf (Tick _ e) = litOf e + litOf _ = Nothing + instance OutputableBndr b => Outputable (Bind b) where ppr bind = ppr_bind noAnn bind ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -1594,6 +1594,7 @@ initSDocContext dflags style = SDC , sdocSuppressModulePrefixes = gopt Opt_SuppressModulePrefixes dflags , sdocSuppressStgExts = gopt Opt_SuppressStgExts dflags , sdocSuppressStgReps = gopt Opt_SuppressStgReps dflags + , sdocStableCoreDumpOrder = gopt Opt_StableCoreDumpOrder dflags , sdocErrorSpans = gopt Opt_ErrorSpans dflags , sdocStarIsType = xopt LangExt.StarIsType dflags , sdocLinearTypes = xopt LangExt.LinearTypes dflags ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -859,6 +859,10 @@ data GeneralFlag | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps | Opt_SuppressCoreSizes -- ^ Suppress per binding Core size stats in dumps + -- | Reorder top-level bindings in Core dumps into a stable, diffable order. + -- See Note [Stable Core dump order] in GHC.Core.Ppr. + | Opt_StableCoreDumpOrder + -- Error message suppression | Opt_ShowErrorContext ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2468,6 +2468,7 @@ dFlagsDeps = [ flagSpec "ppr-case-as-let" Opt_PprCaseAsLet, depFlagSpec' "ppr-ticks" Opt_PprShowTicks (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)), + flagSpec "stable-core-dump-order" Opt_StableCoreDumpOrder, flagSpec "suppress-ticks" Opt_SuppressTicks, depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts (useInstead "-d" "suppress-stg-exts"), ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -422,6 +422,7 @@ data SDocContext = SDC , sdocSuppressModulePrefixes :: !Bool , sdocSuppressStgExts :: !Bool , sdocSuppressStgReps :: !Bool + , sdocStableCoreDumpOrder :: !Bool , sdocErrorSpans :: !Bool , sdocStarIsType :: !Bool , sdocLinearTypes :: !Bool @@ -490,6 +491,7 @@ defaultSDocContext = SDC , sdocSuppressModulePrefixes = False , sdocSuppressStgExts = False , sdocSuppressStgReps = True + , sdocStableCoreDumpOrder = False , sdocErrorSpans = False , sdocStarIsType = False , sdocLinearTypes = False ===================================== docs/users_guide/debugging.rst ===================================== @@ -959,6 +959,33 @@ parts that you are not interested in. has shown you where to look, you can try again without :ghc-flag:`-dsuppress-uniques` +.. ghc-flag:: -dstable-core-dump-order + :shortdesc: Reorder top-level bindings in Core dumps into a stable, + diffable order + :type: dynamic + :reverse: -dno-stable-core-dump-order + :category: verbosity + + :since: 10.2.1 + + Normally the order of top-level bindings in a Core dump (such as the + output of :ghc-flag:`-ddump-simpl`) reflects the compiler's internal + processing order, which depends on ``Unique`` values. Those uniques can + shift whenever an unrelated upstream module changes, so the bindings get + re-ordered and a textual ``diff`` of two dumps fails to line up the real + changes. + + This flag is opt-in and reorders the top-level bindings of Core dumps that + go through the pass-result printer (e.g. :ghc-flag:`-ddump-simpl`, + :ghc-flag:`-ddump-prep`, :ghc-flag:`-ddump-ds`, + :ghc-flag:`-ddump-simpl-iterations`) into a stable, source-location-driven + order that does not depend on uniques. + + It is intended to be combined with :ghc-flag:`-dsuppress-uniques` when + diffing two dumps, but because the ordering does not depend on uniques the + output is also more diffable without it. The default (in-compiler) order is + retained because it is useful when debugging the compiler itself. + .. ghc-flag:: -dsuppress-idinfo :shortdesc: Suppress extended information about identifiers where they are bound ===================================== testsuite/tests/simplCore/should_compile/Makefile ===================================== @@ -298,3 +298,21 @@ T17901: $(RM) -f T17901.o T17901.hi '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl -dsuppress-uniques T17901.hs | grep 'wombat' # All three functions should get their case alternatives combined + +# Check -dstable-core-dump-order on a small Data.Map-style module. The +# sed allow-list prints, deduplicated, the top-level binders we care about in +# dump order. It inspects names only, so it is insensitive to unrelated +# Core-format churn. +# +# The allow-list covers one binder of each interesting category, so the test +# exercises the clustering of generated binders next to their origin: +# * derived instances ($fEqKey/$fOrdKey/$fOrdKey_$ccompare), +# * a call-site specialisation (findI_$slookupG, from lookupG's SPECIALISE), and +# * a recursive worker ($wrotate). +T27296: + $(RM) -f T27296.o T27296.hi + '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl -dsuppress-uniques \ + -dsuppress-idinfo -dsuppress-module-prefixes -dno-typeable-binds \ + -dstable-core-dump-order T27296.hs 2> /dev/null \ + | sed -nE 's/^(\$$fEqKey|\$$fOrdKey|\$$fOrdKey_\$$ccompare|size|findI_\$$slookupG|lookupG|member|findI|\$$wrotate|rotate|insertG|insertManyI|insertTwoI|weight|balance|ratios|fromAscI)( .*)?$$/\1/p' \ + | uniq ===================================== testsuite/tests/simplCore/should_compile/T27296.hs ===================================== @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns #-} + +-- See Note [Stable Core dump order] in GHC.Core.Ppr. +-- +-- A small Data.Map-style module exercising the trickier parts of the stable +-- dump ordering. Under -O it produces, alongside the user functions: +-- * derived Eq/Ord instances for a custom Key type ($fEqKey/$fOrdKey/...), +-- * a call-site specialisation of lookupG (findI_$slookupG), and +-- * a worker/wrapper split of the recursive, strict rotate ($wrotate). +-- Each generated binder inherits its origin's source span, so the stable order +-- clusters it next to that origin. The source order is deliberately neither +-- alphabetical nor the default dump order (insertG forward-references balance), +-- so the test pins source-position ordering specifically. +module T27296 + ( Key(..), size, lookupG, member, findI, rotate, insertG, insertManyI + , insertTwoI, weight, balance, ratios, fromAscI ) + where + +-- A custom key with a derived Ord instance: the derived $fEqKey/$fOrdKey +-- binders inherit this declaration's source span, so they cluster here. +data Key = Key Int deriving (Eq, Ord) + +data Map k a = Tip | Bin !Int k a !(Map k a) !(Map k a) + +data Sizes = Sizes !Int !Int + +size :: Map k a -> Int +size Tip = 0 +size (Bin sz _ _ _ _) = sz + +lookupG :: Ord k => k -> Map k a -> Maybe a +lookupG _ Tip = Nothing +lookupG k (Bin _ kx x l r) = case compare k kx of + LT -> lookupG k l + GT -> lookupG k r + EQ -> Just x +{-# SPECIALISE lookupG :: Key -> Map Key a -> Maybe a #-} + +member :: Key -> Map Key a -> Bool +member k m = case lookupG k m of + Nothing -> False + Just _ -> True + +findI :: Key -> Map Key a -> a -> a +findI k m def = case lookupG k m of + Nothing -> def + Just v -> v + +-- rotate is recursive and strict in the product 'Sizes', so worker/wrapper +-- unboxes it into a recursive worker ($wrotate). The loop only repackages the +-- fields (no arithmetic), so the worker is stable across build flavours. +rotate :: Sizes -> [a] -> Sizes +rotate s [] = s +rotate (Sizes a b) (_:xs) = rotate (Sizes b a) xs + +-- insertG references 'balance', which is defined further down (forward ref). +insertG :: Ord k => k -> a -> Map k a -> Map k a +insertG k x Tip = Bin 1 k x Tip Tip +insertG k x (Bin sz kx kv l r) = case compare k kx of + LT -> balance kx kv (insertG k x l) r + GT -> balance kx kv l (insertG k x r) + EQ -> Bin sz k x l r +{-# SPECIALISE insertG :: Key -> a -> Map Key a -> Map Key a #-} + +insertManyI :: [(Key, a)] -> Map Key a -> Map Key a +insertManyI xs m0 = foldr (\(k, x) m -> insertG k x m) m0 xs + +insertTwoI :: Key -> Key -> a -> Map Key a +insertTwoI k1 k2 x = insertG k1 x (insertG k2 x Tip) + +-- weight unboxes the strict fields of Sizes -> worker/wrapper $wweight. +weight :: Sizes -> Int +weight (Sizes a b) = a * a + 3 * b * b + a * b + 1 + +balance :: k -> a -> Map k a -> Map k a -> Map k a +balance k x l r = Bin (weight (Sizes sl sr)) k x l r + where + sl = size l + sr = size r + +-- baseRatios is a closed constant under a lambda -> floated to a top-level lvl. +ratios :: Int -> [Int] +ratios n = map (n +) baseRatios + where baseRatios = [2, 3, 5, 7, 11, 13] + +fromAscI :: [(Key, a)] -> Map Key a +fromAscI = foldr (\(k, x) m -> insertG k x m) Tip ===================================== testsuite/tests/simplCore/should_compile/T27296.stdout ===================================== @@ -0,0 +1,17 @@ +$fEqKey +$fOrdKey +$fOrdKey_$ccompare +size +findI_$slookupG +lookupG +member +findI +$wrotate +rotate +insertG +insertManyI +insertTwoI +weight +balance +ratios +fromAscI ===================================== testsuite/tests/simplCore/should_compile/T27296b.hs ===================================== @@ -0,0 +1,21 @@ +-- See Note [Stable Core dump order] in GHC.Core.Ppr. +-- +-- Companion to T27296 that pins the ordering of *anonymous* top-level floats. +-- Under -O the boxed Int constants in sel's branches are floated to top level +-- as separate CAFs, all of which the compiler names "lvl" with noSrcSpan (see +-- newLvlVar). Before -dstable-core-dump-order their dump order was the +-- unique-driven processing order; the flag's content-based tie-break (rhsKey) +-- now orders them by literal value -- here 1000..6000, despite the scrambled +-- source order. This dump is intentionally *untidied* (-ddump-float-out), the +-- only place the "lvl" collision is observable; tidied dumps like -ddump-simpl +-- already give the floats distinct names (lvl, lvl1, ...). +module T27296b (sel) where + +{-# NOINLINE sel #-} +sel :: Int -> Int +sel 0 = 5000 +sel 1 = 1000 +sel 2 = 4000 +sel 3 = 2000 +sel 4 = 3000 +sel _ = 6000 ===================================== testsuite/tests/simplCore/should_compile/T27296b.stderr ===================================== @@ -0,0 +1,84 @@ + +==================== Float out(FOS {Lam = Just 0, + Consts = True, + JoinsToTop = False, + OverSatApps = False}) ==================== +Result size of Float out(FOS {Lam = Just 0, + Consts = True, + JoinsToTop = False, + OverSatApps = False}) + = {terms: 37, types: 12, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 18, types: 4, coercions: 0, joins: 0/0} +sel :: Int -> Int +sel + = \ (ds :: Int) -> + case ds of { I# ds -> + case ds of { + __DEFAULT -> lvl; + 0# -> lvl; + 1# -> lvl; + 2# -> lvl; + 3# -> lvl; + 4# -> lvl + } + } + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl :: Int +lvl = I# 1000# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl :: Int +lvl = I# 2000# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl :: Int +lvl = I# 3000# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl :: Int +lvl = I# 4000# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl :: Int +lvl = I# 5000# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl :: Int +lvl = I# 6000# + + + + +==================== Float out(FOS {Lam = Just 0, + Consts = True, + JoinsToTop = True, + OverSatApps = True}) ==================== +Result size of Float out(FOS {Lam = Just 0, + Consts = True, + JoinsToTop = True, + OverSatApps = True}) + = {terms: 27, types: 10, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 15, types: 2, coercions: 0, joins: 0/0} +$wsel :: Int# -> Int# +$wsel + = \ (ww :: Int#) -> + case ww of { + __DEFAULT -> 6000#; + 0# -> 5000#; + 1# -> 1000#; + 2# -> 4000#; + 3# -> 2000#; + 4# -> 3000# + } + +-- RHS size: {terms: 10, types: 4, coercions: 0, joins: 0/0} +sel :: Int -> Int +sel + = \ (ds :: Int) -> + case ds of { I# ww -> case $wsel ww of ww { __DEFAULT -> I# ww } } + + + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -602,3 +602,6 @@ test('T25718b', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress test('T25718c', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) test('T19166', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O']) +test('T27296', [], makefile_test, ['T27296']) +test('T27296b', only_ways(['optasm']), compile, + ['-O -ddump-float-out -dsuppress-uniques -dsuppress-idinfo -dsuppress-module-prefixes -dno-typeable-binds -dstable-core-dump-order']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/572b3a913ea825365c4d677363a926… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/572b3a913ea825365c4d677363a926… You're receiving this email because of your account on gitlab.haskell.org.

1 0