Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
7bf9e3c5 by Teo Camarasu at 2026-06-30T21:38:03-04: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 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/700
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,9 @@
+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``.
+ The ``Quasi TcM`` instance is no longer exposed from the ``ghc`` API.
+ See the `GHC proposal <https://github.com/ghc-proposals/ghc-proposals/pull/700>`_ for more details.
+mrs: !15696
+issues: #27341
=====================================
compiler/GHC/Data/IOEnv.hs
=====================================
@@ -22,7 +22,7 @@ module GHC.Data.IOEnv (
IOEnvFailure(..),
-- Getting at the environment
- getEnv, setEnv, updEnv, updEnvIO,
+ getEnv, setEnv, updEnv, updEnvIO, withRunInIO,
runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_,
tryM, tryAllM, tryMostM, fixM,
@@ -258,3 +258,12 @@ 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)
+
+-- | 'withRunInIO' specialised to `IOEnv`.
+-- See https://hackage.haskell.org/package/unliftio-core/docs/Control-Monad-IO-Unl… for an explanation.
+withRunInIO:: forall env b. ((forall a. IOEnv env a -> IO a) -> IO b) -> IOEnv env b
+withRunInIO 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) = withRunInIO $ \runInIO -> 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,131 @@ 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
+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.
+ , 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 +1810,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 +1819,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 +1935,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
=====================================
@@ -29,13 +29,13 @@ import Data.Data hiding (Fixity(..))
import Data.IORef
import System.IO.Unsafe (unsafePerformIO)
import Control.Monad.IO.Class (MonadIO (..))
-import System.IO (FilePath, hPutStrLn, stderr)
+import System.IO (hPutStrLn, stderr)
import qualified Data.Kind as Kind (Type)
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,150 @@ 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)
+-- | 'MetaHandlers' defines the interface between GHC and TH splices.
+-- This is an internal interface between two parts of the compiler,
+-- and should never be directly exposed to users.
+--
+-- It mirrors the 'Quasi' typeclass, which is part of the public facing interface of TH.
+-- With time the two interfaces may drift apart.
+--
+-- This type is defined in `ghc-internal` rather than `lib:ghc` to avoid
+-- `template-haskell` having to depend on GHC, ie, it implements dependency inversion.
+--
+-- For more information about the historical design of this interface,
+-- see: https://github.com/ghc-proposals/ghc-proposals/pull/700
+data MetaHandlers = MetaHandlers {
+ -- | We have an explicit handler for liftIO to allow users to forbid lifting into 'IO'
+ mLiftIO :: forall a. IO a -> IO a
+ , mFail :: forall a. String -> IO a
+ -- | Fresh names. See 'newName'.
+ , mNewName :: String -> IO Name
+
+ ------- Error reporting and recovery -------
+ -- | Report an error (True) or warning (False)
+ -- ...but carry on; use 'fail' to stop. See 'report'.
+ , mReport :: Bool -> String -> IO ()
+
+ -- | See 'recover'.
+ , mRecover :: forall a. Q a -- ^ the error handler
+ -> Q a -- ^ action which may fail
+ -> IO a -- ^ Recover from the monadic 'fail'
+
+ ------- Inspect the type-checker's environment -------
+ -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
+ , mLookupName :: Bool -> String -> IO (Maybe Name)
+ -- | See 'reify'.
+ , mReify :: Name -> IO Info
+ -- | See 'reifyFixity'.
+ , mReifyFixity :: Name -> IO (Maybe Fixity)
+ -- | See 'reifyType'.
+ , mReifyType :: Name -> IO 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] -> IO [Dec]
+ -- | See 'reifyRoles'.
+ , mReifyRoles :: Name -> IO [Role]
+ -- | See 'reifyAnnotations'.
+ , mReifyAnnotations :: forall a. Data a => AnnLookup -> IO [a]
+ -- | See 'reifyModule'.
+ , mReifyModule :: Module -> IO ModuleInfo
+ -- | See 'reifyConStrictness'.
+ , mReifyConStrictness :: Name -> IO [DecidedStrictness]
+
+ -- | See 'location'.
+ , mLocation :: IO Loc
+
+ -- | See 'getPackageRoot'.
+ , mGetPackageRoot :: IO FilePath
+
+ -- | See 'addDependentFile'.
+ , mAddDependentFile :: FilePath -> IO ()
+
+ -- | See 'addDependentDirectory'.
+ , mAddDependentDirectory :: FilePath -> IO ()
+
+ -- | See 'addTempFile'.
+ , mAddTempFile :: String -> IO FilePath
+
+ -- | See 'addTopDecls'.
+ , mAddTopDecls :: [Dec] -> IO ()
+
+ -- | See 'addForeignFilePath'.
+ , mAddForeignFilePath :: ForeignSrcLang -> String -> IO ()
+
+ -- | See 'addModFinalizer'.
+ , mAddModFinalizer :: Q () -> IO ()
+
+ -- | See 'addCorePlugin'.
+ , mAddCorePlugin :: String -> IO ()
+
+ -- | See 'getQ'.
+ , mGetQ :: forall a. Typeable a => IO (Maybe a)
+
+ -- | See 'putQ'.
+ , mPutQ :: forall a. Typeable a => a -> IO ()
+
+ -- | See 'isExtEnabled'.
+ , mIsExtEnabled :: Extension -> IO Bool
+ -- | See 'extsEnabled'.
+ , mExtsEnabled :: IO [Extension]
+
+ -- | See 'putDoc'.
+ , mPutDoc :: DocLoc -> String -> IO ()
+ -- | See 'getDoc'.
+ , mGetDoc :: DocLoc -> IO (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
+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 #-}
@@ -210,46 +215,24 @@ counter = unsafePerformIO (newIORef 0)
--
-----------------------------------------------------
--- | In short, 'Q' provides the 'Quasi' operations in one neat monad for the
--- user.
---
--- The longer story, is that 'Q' wraps an arbitrary 'Quasi'-able monad.
--- The perceptive reader notices that 'Quasi' has only two instances, 'Q'
--- itself and 'IO', neither of which have concrete implementations.'Q' plays
--- the trick of [dependency
--- 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
+-- | 'Q' is the base 'Monad' for TemplateHaskell splices,
+-- similar to how 'IO' is the base 'Monad' for normal Haskell programs.
+newtype Q a = Q { unQ :: MetaHandlers -> 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 +302,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,35 +500,26 @@ 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)
-{-# 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'.
-reportError :: String -> Q ()
-reportError = report True
-
--- | Report a warning to the user, and carry on.
-reportWarning :: String -> Q ()
-reportWarning = report False
+report b s = Q $ \h -> mReport h b s
-- | Recover from errors raised by 'reportError' or 'fail'.
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 +594,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 +603,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 +611,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 +703,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 +722,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 +750,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 +763,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 +773,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 +785,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 +804,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 +818,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 +837,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 +846,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 +856,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 +870,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 +902,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
+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,17 @@
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE UnboxedTuples #-}
+-- Don't warn for using 'report' from ghc-internal
+{-# 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 (..),
@@ -202,11 +206,14 @@ where
import GHC.Boot.TH.Lift
import GHC.Boot.TH.Syntax
-import GHC.Boot.TH.Monad
+import GHC.Boot.TH.Monad hiding (report)
+import qualified GHC.Boot.TH.Monad as Internal
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 +506,172 @@ 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
+--
+-----------------------------------------------------
+
+-- | The 'Quasi' typeclass used to provide an exhaustive list of the effects exposed by the 'Q' monad.
+-- This invariant no longer holds, and it is encouraged to use 'Q' or 'Quote' instead.
+class (MonadIO m, MonadFail m) => Quasi m where
+ qRunQ :: Q a -> m a
+ -- | Fresh names. See 'newName'.
+ qNewName :: String -> m Name
+ qNewName = qRunQ . newName
+
+ ------- Error reporting and recovery -------
+ -- | Report an error (True) or warning (False)
+ -- ...but carry on; use 'fail' to stop. See 'report'.
+ qReport :: Bool -> String -> m ()
+ qReport b s = qRunQ $ report b s
+
+ -- | 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)
+ qLookupName ns s = qRunQ $ lookupName ns s
+ -- | See 'reify'.
+ qReify :: Name -> m Info
+ qReify v = qRunQ $ reify v
+ -- | See 'reifyFixity'.
+ qReifyFixity :: Name -> m (Maybe Fixity)
+ qReifyFixity v = qRunQ $ reifyFixity v
+ -- | See 'reifyType'.
+ qReifyType :: Name -> m Type
+ qReifyType v = qRunQ $ reifyType v
+ -- | 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]
+ qReifyInstances cls tys = qRunQ $ reifyInstances cls tys
+ -- | See 'reifyRoles'.
+ qReifyRoles :: Name -> m [Role]
+ qReifyRoles nm = qRunQ $ reifyRoles nm
+ -- | See 'reifyAnnotations'.
+ qReifyAnnotations :: Data a => AnnLookup -> m [a]
+ qReifyAnnotations an = qRunQ $ reifyAnnotations an
+ -- | See 'reifyModule'.
+ qReifyModule :: Module -> m ModuleInfo
+ qReifyModule m = qRunQ $ reifyModule m
+ -- | See 'reifyConStrictness'.
+ qReifyConStrictness :: Name -> m [DecidedStrictness]
+ qReifyConStrictness nm = qRunQ $ reifyConStrictness nm
+
+ -- | See 'location'.
+ qLocation :: m Loc
+ qLocation = qRunQ location
+
+ -- | Input/output (dangerous). See 'runIO'.
+ qRunIO :: IO a -> m a
+ qRunIO = liftIO
+ -- | See 'getPackageRoot'.
+ qGetPackageRoot :: m FilePath
+ qGetPackageRoot = qRunQ getPackageRoot
+
+ -- | See 'addDependentFile'.
+ qAddDependentFile :: FilePath -> m ()
+ qAddDependentFile p = qRunQ $ addDependentFile p
+
+ -- | See 'addDependentDirectory'.
+ qAddDependentDirectory :: FilePath -> m ()
+ qAddDependentDirectory p = qRunQ $ addDependentDirectory p
+
+ -- | See 'addTempFile'.
+ qAddTempFile :: String -> m FilePath
+ qAddTempFile p = qRunQ $ addTempFile p
+
+ -- | See 'addTopDecls'.
+ qAddTopDecls :: [Dec] -> m ()
+ qAddTopDecls decls = qRunQ $ addTopDecls decls
+
+ -- | See 'addForeignFilePath'.
+ qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
+ qAddForeignFilePath lang fp = qRunQ $ addForeignFilePath lang fp
+
+ -- | See 'addModFinalizer'.
+ qAddModFinalizer :: Q () -> m ()
+ qAddModFinalizer fin = qRunQ $ addModFinalizer fin
+
+ -- | See 'addCorePlugin'.
+ qAddCorePlugin :: String -> m ()
+ qAddCorePlugin nm = qRunQ $ addCorePlugin nm
+
+ -- | See 'getQ'.
+ qGetQ :: Typeable a => m (Maybe a)
+ qGetQ = qRunQ getQ
+
+ -- | See 'putQ'.
+ qPutQ :: Typeable a => a -> m ()
+ qPutQ x = qRunQ $ putQ x
+
+ -- | See 'isExtEnabled'.
+ qIsExtEnabled :: Extension -> m Bool
+ qIsExtEnabled ext = qRunQ $ isExtEnabled ext
+ -- | See 'extsEnabled'.
+ qExtsEnabled :: m [Extension]
+ qExtsEnabled = qRunQ extsEnabled
+
+ -- | See 'putDoc'.
+ qPutDoc :: DocLoc -> String -> m ()
+ qPutDoc l s = qRunQ $ putDoc l s
+ -- | See 'getDoc'.
+ qGetDoc :: DocLoc -> m (Maybe String)
+ qGetDoc l = qRunQ $ getDoc l
+
+-- | \"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. Please use 'Quote' instead, which is much safer.
+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)
+ qRecover _ _ = badIO "recover" -- Maybe we could fix this?
+
+instance Quasi Q where
+ qRunQ = id
+ qRecover = recover
+
+
+-- | Report an error (True) or warning (False),
+-- but carry on; use 'fail' to stop.
+report :: Bool -> String -> Q ()
+report = Internal.report
+{-# 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'.
+reportError :: String -> Q ()
+reportError = report True
+
+-- | Report a warning to the user, and carry on.
+reportWarning :: String -> Q ()
+reportWarning = report False
=====================================
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, qRecover #-}
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/7bf9e3c51c668f2d5fd6951f57356e8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7bf9e3c51c668f2d5fd6951f57356e8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] 2 commits: Decoupling 'L.H.S' from 'GHC.Types.SourceText'
by Marge Bot (＠marge-bot) 01 Jul '26
by Marge Bot (＠marge-bot) 01 Jul '26
01 Jul '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
d7cfea49 by Recursion Ninja at 2026-06-30T21:37:12-04:00
Decoupling 'L.H.S' from 'GHC.Types.SourceText'
* Migrated 'IntegralLit' to 'L.H.S.Lit'.
* Migrated 'FractionalLit' to 'L.H.S.Lit'.
* Migrated 'StringLiteral' to 'L.H.S.Lit'.
* Added TTG extension points to the types above.
* Added nice export list to 'GHC.Hs.Lit'.
* Added 'rnOverLitVal' and 'tcOverLitVal' functions to 'GHC.Hs.Lit'.
* Added instance 'Anno (StringLiteral (GhcPass p)) = SrcSpanAnnN'
* Moved [Notes] about 'SourceText' from 'L.H.S.*' to 'GHC.*'.
* Removed all references to 'SourceText' from 'L.H.S'.
* Removed the trailing comma record field from 'StringLiteral'
* Renamed exported functions for nomenclature consistency.
* Deprecated the renamed functions
Fixes #26953
- - - - -
a1f2558b by Recursion Ninja at 2026-06-30T21:37:12-04:00
Monomorphising GHC pass parameters where appropriate
- - - - -
53 changed files:
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Lit.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Warnings.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/HaddockLex.x
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Lit.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/PkgQual.hs
- compiler/GHC/Types/SourceText.hs
- compiler/GHC/Unit/Module/Warnings.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Binds/InlinePragma.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Decls/Foreign.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Lit.hs
- testsuite/tests/ghc-api/annotations-literals/literals.stdout
- testsuite/tests/ghc-api/annotations-literals/parsed.hs
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf7b5ce65f470f21eee29007f3d6a1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf7b5ce65f470f21eee29007f3d6a1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
30 Jun '26
Alan Zimmerman pushed new branch wip/az/epa-tidy-locatedxxx-4 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/epa-tidy-locatedxxx-4
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 3 commits: Fix ppr for ClassDecl to include DocDs
by Alan Zimmerman (＠alanz) 30 Jun '26
by Alan Zimmerman (＠alanz) 30 Jun '26
30 Jun '26
Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC
Commits:
b11d4a77 by Alan Zimmerman at 2026-06-29T20:53:00+01:00
Fix ppr for ClassDecl to include DocDs
- - - - -
38ffb9b2 by Alan Zimmerman at 2026-06-29T21:53:45+01:00
Some tidy ups of the decls stuff. Squash it in
- - - - -
ad58bb76 by Alan Zimmerman at 2026-06-30T22:35:08+01:00
EPA: ClsInstDecl as list in GhcPs
- - - - -
31 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Stats.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- testsuite/tests/haddock/haddock_examples/haddock.Test.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/printer/Test24533.stdout
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/74e5c1828c656a858fe83b55c36ea5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/74e5c1828c656a858fe83b55c36ea5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: rts: handle large AP closures in compacting GC
by Marge Bot (＠marge-bot) 30 Jun '26
by Marge Bot (＠marge-bot) 30 Jun '26
30 Jun '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
cca0d589 by Luite Stegeman at 2026-06-30T13:33:40-04:00
rts: handle large AP closures in compacting GC
The function update_fwd_large in the compacting GC could run into
an unexpected object with the following error:
internal error: update_fwd_large: unknown/strange object 24
Closure type 24 is the AP closure, which was not handled in
upd_fwd_large. This patch adds handling them.
fixes #27434
- - - - -
42935858 by Luite Stegeman at 2026-06-30T13:33:40-04:00
testsuite: use compacting_gc way instead of hardcoding +RTS -c
- - - - -
bf7b5ce6 by Alan Zimmerman at 2026-06-30T13:34:23-04:00
EPA: Remove LocatedLW from LStmtLR
HsDo already had its XDo extension point for an
AnnList, which also appeared in LocatedLW.
So we remove the redundant one and use the one inside HsDo
as originally intended.
Also delete LocatedLC/LocatedLS as they were unused
- - - - -
7fe5cd43 by Recursion Ninja at 2026-06-30T14:06:25-04:00
Decoupling 'L.H.S' from 'GHC.Types.SourceText'
* Migrated 'IntegralLit' to 'L.H.S.Lit'.
* Migrated 'FractionalLit' to 'L.H.S.Lit'.
* Migrated 'StringLiteral' to 'L.H.S.Lit'.
* Added TTG extension points to the types above.
* Added nice export list to 'GHC.Hs.Lit'.
* Added 'rnOverLitVal' and 'tcOverLitVal' functions to 'GHC.Hs.Lit'.
* Added instance 'Anno (StringLiteral (GhcPass p)) = SrcSpanAnnN'
* Moved [Notes] about 'SourceText' from 'L.H.S.*' to 'GHC.*'.
* Removed all references to 'SourceText' from 'L.H.S'.
* Removed the trailing comma record field from 'StringLiteral'
* Renamed exported functions for nomenclature consistency.
* Deprecated the renamed functions
Fixes #26953
- - - - -
7b86fa2b by Recursion Ninja at 2026-06-30T14:06:25-04:00
Monomorphising GHC pass parameters where appropriate
- - - - -
a0961475 by Teo Camarasu at 2026-06-30T14:06:27-04: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 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/700
Resolves #27341
- - - - -
5b719ee0 by L0neGamer at 2026-06-30T14:06:32-04:00
generically defines mconcat in terms of internal type's Semigroup instance
add changelog entry
use simpler definition for mconcat
`nonEmpty` isn't available yet; inline branches in case
add test case
fixup generically defines mconcat in terms of internal type's Semigroup instance
add comment on Generically and deriving mishaps
swap mconcat to foldr version
add some strictness testing for mconcat
add to `base` changelog entry
- - - - -
0a081cdd by Cheng Shao at 2026-06-30T14:06:33-04:00
hadrian/rts: fix unregisterised build for gcc 15+
This patch fixes unregisterised build for gcc 15+:
- Pass -optc-Wno-error in hadrian when +werror enables -optc-Werror,
see added comment for details.
- For RTS functions that the codegen would emit calls, ensure their
real prototype is hidden when the header is included in .hc fies
(IN_STG_CODE), and the dummy prototype is provided to match the EFF_
convention.
In the future we should get rid of EFF_ (#14647) and remove these
hacks, but for now this patch makes unregisterised work again on newer
toolchains. Fixes #27404.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
095432f6 by Cheng Shao at 2026-06-30T14:06:35-04:00
compiler: fix missing handling of CmmUnsafeForeignCall node in LayoutStack
This patch fixes missing handling of `CmmUnsafeForeignCall` middle
node in the `LayoutStack` pass.
Before proc-points splitting, this pass computes liveliness of local
registers, and spills those alive across a Cmm native call onto the
stack. It need to traverse all middle nodes in each block and check
whether a local register is an assignee, if so then the previous
mapping in `sm_regs` is invalidated and needs to be dropped. However,
it didn't handle `CmmUnsafeForeignCall` node which may also assign to
a local register. When proc-points splitting is enabled, this can
produce an invalid basic block that doesn't properly backup the
updated local register to the stack before doing a Cmm call, resulting
in completely invalid runtime behavior.
The patch also adds a `T27447` regression test. With no-TNTC or with
LLVM backend, without the fix the test case would output a stale
0x1111111111111111 value, instead of the expected 0x2222222222222222
output.
Fixes #27447.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
93 changed files:
- + changelog.d/AbstractQ
- + changelog.d/fix-compacting-gc-ap-27434
- + changelog.d/fix-layout-stack-fcall
- + changelog.d/fix-unreg
- + changelog.d/generically-mconcat
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Cmm/LayoutStack.hs
- compiler/GHC/Data/IOEnv.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Lit.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Warnings.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/HaddockLex.x
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/Types.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Lit.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/PkgQual.hs
- compiler/GHC/Types/SourceText.hs
- compiler/GHC/Unit/Module/Warnings.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Binds/InlinePragma.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Decls/Foreign.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Lit.hs
- hadrian/src/Flavour.hs
- libraries/base/changelog.md
- libraries/ghc-internal/src/GHC/Internal/Generics.hs
- 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
- rts/include/rts/NonMoving.h
- rts/include/stg/MiscClosures.h
- rts/sm/Compact.c
- + testsuite/tests/cmm/should_run/T27447.hs
- + testsuite/tests/cmm/should_run/T27447.stdout
- + testsuite/tests/cmm/should_run/T27447_cmm.cmm
- testsuite/tests/cmm/should_run/all.T
- + testsuite/tests/generics/T27245.hs
- + testsuite/tests/generics/T27245.stdout
- testsuite/tests/generics/all.T
- testsuite/tests/ghc-api/annotations-literals/literals.stdout
- testsuite/tests/ghc-api/annotations-literals/parsed.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/printer/Test20297.stdout
- + testsuite/tests/rts/T27434.hs
- + testsuite/tests/rts/T27434.stdout
- testsuite/tests/rts/all.T
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/51ace0b43d4f652c0d8085f44e22ed…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/51ace0b43d4f652c0d8085f44e22ed…
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] Make `cabal` run in the correct directory
by Wolfgang Jeltsch (＠jeltsch) 30 Jun '26
by Wolfgang Jeltsch (＠jeltsch) 30 Jun '26
30 Jun '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/ghc-9-14-building-base at Glasgow Haskell Compiler / GHC
Commits:
15e7d73d by Wolfgang Jeltsch at 2026-06-30T20:52:03+03:00
Make `cabal` run in the correct directory
- - - - -
1 changed file:
- .gitlab-ci.yml
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -1171,9 +1171,11 @@ base-build-with-released-ghcs:
./configure --prefix "$PWD/../ghc-${ghc_version}-installed"
make install
cd -
+ cd libraries/base
cabal build --with-compiler ghc-${ghc_version}-installed/bin/ghc \
--allow-boot-library-installs \
-O0
+ cd -
done
rules:
- *full-ci
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/15e7d73d4b2d5216a9630c292ed1ffa…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/15e7d73d4b2d5216a9630c292ed1ffa…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
30 Jun '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
bf7b5ce6 by Alan Zimmerman at 2026-06-30T13:34:23-04:00
EPA: Remove LocatedLW from LStmtLR
HsDo already had its XDo extension point for an
AnnList, which also appeared in LocatedLW.
So we remove the redundant one and use the one inside HsDo
as originally intended.
Also delete LocatedLC/LocatedLS as they were unused
- - - - -
12 changed files:
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/Types.hs
- compiler/GHC/Tc/Gen/Match.hs
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/printer/Test20297.stdout
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -69,6 +69,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
`extQ` annotationAnnList
`extQ` annotationAnnListWhere
`extQ` annotationAnnListCommas
+ `extQ` annotationAnnListEpaLocation
`extQ` annotationNoEpAnns
`extQ` annotationExprBracket
`extQ` annotationTypedBracket
@@ -375,6 +376,12 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
annotationAnnListCommas :: EpAnn (AnnList [EpToken ","]) -> SDoc
annotationAnnListCommas = annotation' (text "EpAnn (AnnList [EpToken \",\"])")
+ annotationAnnListEpaLocation :: AnnList EpaLocation -> SDoc
+ annotationAnnListEpaLocation anns = case ba of
+ BlankEpAnnotations -> parens (text "blanked:" <+> text "AnnList EpaLocation")
+ NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns))
+ $$ vcat (gmapQ showAstData' anns)
+
annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc
annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns")
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -535,9 +535,6 @@ type instance XPragE (GhcPass _) = NoExtField
type instance XFunRhs = AnnFunRhs
-type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnLW
-type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA
-
mkHsVar :: forall p. IsPass p => LIdP (GhcPass p) -> HsExpr (GhcPass p)
mkHsVar n = HsVar noExtField $
case ghcPass @p of
@@ -2648,8 +2645,8 @@ instance UnXRec p => Outputable (DotFieldOcc p) where
type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA
type instance Anno [LocatedA (HsExpr (GhcPass p))] = SrcSpanAnnA
-type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnLW
-type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnLW
+type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnA
+type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnA
type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA
@@ -2665,7 +2662,7 @@ type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr
type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA
-type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnLW
+type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnA
type instance Anno (FieldLabelStrings (GhcPass p)) = EpAnnCO
type instance Anno FieldLabelString = SrcSpanAnnN
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -320,8 +320,8 @@ nlParPat p = noLocA (gParPat p)
mkHsIntegral :: IntegralLit -> HsOverLit GhcPs
mkHsFractional :: FractionalLit -> HsOverLit GhcPs
mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs
-mkHsDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> HsExpr GhcPs
-mkHsDoAnns :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs
+mkHsDo :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> HsExpr GhcPs
+mkHsDoAnns :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs
mkHsComp :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
-> HsExpr GhcPs
mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
@@ -349,12 +349,12 @@ mkTcBindStmt :: LPat GhcTc -> LocatedA (bodyR GhcTc)
emptyRecStmt :: (Anno [GenLocated
(Anno (StmtLR (GhcPass idL) GhcPs bodyR))
(StmtLR (GhcPass idL) GhcPs bodyR)]
- ~ SrcSpanAnnLW)
+ ~ SrcSpanAnnA)
=> StmtLR (GhcPass idL) GhcPs bodyR
emptyRecStmtName :: (Anno [GenLocated
(Anno (StmtLR GhcRn GhcRn bodyR))
(StmtLR GhcRn GhcRn bodyR)]
- ~ SrcSpanAnnLW)
+ ~ SrcSpanAnnA)
=> StmtLR GhcRn GhcRn bodyR
emptyRecStmtId :: Stmt GhcTc (LocatedA (HsCmd GhcTc))
@@ -362,9 +362,9 @@ mkRecStmt :: forall (idL :: Pass) bodyR.
(Anno [GenLocated
(Anno (StmtLR (GhcPass idL) GhcPs bodyR))
(StmtLR (GhcPass idL) GhcPs bodyR)]
- ~ SrcSpanAnnLW)
+ ~ SrcSpanAnnA)
=> AnnList (EpToken "rec")
- -> LocatedLW [LStmtLR (GhcPass idL) GhcPs bodyR]
+ -> LocatedA [LStmtLR (GhcPass idL) GhcPs bodyR]
-> StmtLR (GhcPass idL) GhcPs bodyR
mkRecStmt anns stmts = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR)
{ recS_stmts = stmts }
=====================================
compiler/GHC/Parser.y
=====================================
@@ -3144,15 +3144,17 @@ aexp :: { ECP }
return $ ECP $
$2 >>= \ $2 ->
mkHsDoPV (comb2 $1 $2)
+ (stmtlistAnns $2)
(fmap mkModuleNameFS (getDO $1))
- $2
+ (stmtlistStmts $2)
(glR $1)
(glR $2) }
| MDO stmtlist {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 ->
fmap ecpFromExp $
amsA' (L (comb2 $1 $2)
- (mkMDo (MDoExpr $ fmap mkModuleNameFS (getMDO $1))
- $2
+ (mkMDo (stmtlistAnns $2)
+ (MDoExpr $ fmap mkModuleNameFS (getMDO $1))
+ (stmtlistStmts $2)
(glR $1)
(glR $2))) }
| 'proc' aexp '->' exp
@@ -3648,11 +3650,11 @@ apat : aexp {% (checkPattern <=< runPV) (unECP $1) }
-----------------------------------------------------------------------------
-- Statement sequences
-stmtlist :: { forall b. DisambECP b => PV (LocatedLW [LocatedA (Stmt GhcPs (LocatedA b))]) }
+stmtlist :: { forall b. DisambECP b => PV (LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), Located [LocatedA (Stmt GhcPs (LocatedA b))])) }
: '{' stmts '}' { $2 >>= \ $2 ->
- amsr (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2) noAnn []) }
- | vocurly stmts close { $2 >>= \ $2 -> amsr
- (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) ListNone (fromOL $ fst $ unLoc $2) noAnn []) }
+ amsA' (sLL $1 $> ((epTok $1, fromOL $ fst $ unLoc $2, epTok $3), sL1 $2 $ reverse $ snd $ unLoc $2))}
+ | vocurly stmts close { $2 >>= \ $2 ->
+ amsA' (L (stmtsLoc $2) ((NoEpTok, fromOL $ fst $ unLoc $2, NoEpTok), sL1 $2 $ reverse $ snd $ unLoc $2))}
-- do { ;; s ; s ; ; s ;; }
-- The last Stmt should be an expression, but that's hard to enforce
@@ -3694,7 +3696,8 @@ e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }
: qual { $1 }
| 'rec' stmtlist { $2 >>= \ $2 ->
- amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn (epTok $1) $2) $2) }
+ amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn (epTok $1) (stmtlistAnns $2) $2)
+ (stmtlistStmts $2)) }
qual :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }
: bindpat '<-' exp { unECP $3 >>= \ $3 ->
@@ -4717,9 +4720,9 @@ commentsPA la@(L l a) = do
!cs <- getPriorCommentsFor (getLocA la)
return (L (addCommentsToEpAnn l cs) a)
-hsDoAnn :: EpToken "rec" -> LocatedAn t b -> AnnList (EpToken "rec")
-hsDoAnn tok (L ll _)
- = AnnList (Just $ spanAsAnchor (locA ll)) ListNone [] tok []
+hsDoAnn :: EpToken "rec" -> (EpToken "{", [EpToken ";"], EpToken "}") -> LocatedAn t b -> AnnList (EpToken "rec")
+hsDoAnn rec (ob, semis, cb) (L ll _)
+ = AnnList (Just $ spanAsAnchor (locA ll)) (ListBraces ob cb) semis rec []
listAsAnchorM :: [LocatedAn t a] -> Maybe EpaLocation
listAsAnchorM [] = Nothing
@@ -4745,6 +4748,17 @@ epExplicitBraces !t1 !t2 = EpExplicitBraces (epTok t1) (epTok t2)
-- -------------------------------------
+stmtlistStmts :: LocatedA (a, Located [LocatedA (Stmt GhcPs (LocatedA b))])
+ -> LocatedA [LocatedA (Stmt GhcPs (LocatedA b))]
+stmtlistStmts (L la (_,L l stmts))
+ = L ((noAnnSrcSpan l) {comments = comments la}) stmts
+
+stmtlistAnns :: LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), a)
+ -> (EpToken "{", [EpToken ";"], EpToken "}")
+stmtlistAnns (L _ (an,_)) = an
+
+-- -------------------------------------
+
addTrailingCommaFBind :: MonadP m => Fbind b -> EpToken "," -> m (Fbind b)
addTrailingCommaFBind (Left b) l = fmap Left (addTrailingCommaA b l)
addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l)
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -28,10 +28,10 @@ module GHC.Parser.Annotation (
-- ** Annotations in 'GenLocated'
LocatedA, LocatedN, LocatedAn, LocatedP,
- LocatedLC, LocatedLS, LocatedLW,
+ LocatedLW,
LocatedE, LocatedBF,
SrcSpanAnnA, SrcSpanAnnP, SrcSpanAnnN,
- SrcSpanAnnLC, SrcSpanAnnLW, SrcSpanAnnLS,
+ SrcSpanAnnLW,
SrcSpanAnnBF,
-- ** Annotation data types used in 'GenLocated'
@@ -432,18 +432,13 @@ emptyComments = EpaComments []
type LocatedA = GenLocated SrcSpanAnnA
type LocatedN = GenLocated SrcSpanAnnN
-type LocatedLC = GenLocated SrcSpanAnnLC
-type LocatedLS = GenLocated SrcSpanAnnLS
type LocatedLW = GenLocated SrcSpanAnnLW
type LocatedP = GenLocated SrcSpanAnnP
--- type LocatedC = GenLocated SrcSpanAnnC
type LocatedBF = GenLocated SrcSpanAnnBF
type SrcSpanAnnA = EpAnn AnnListItem
type SrcSpanAnnN = EpAnn NameAnn
-type SrcSpanAnnLC = EpAnn (AnnList [EpToken ","])
-type SrcSpanAnnLS = EpAnn (AnnList ())
type SrcSpanAnnLW = EpAnn (AnnList (EpToken "where"))
type SrcSpanAnnP = EpAnn AnnPragma
type SrcSpanAnnBF = EpAnn AnnBooleanFormula
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -436,9 +436,9 @@ mkRoleAnnotDecl loc tycon roles anns
addFatalError $ mkPlainErrorMsgEnvelope loc_role $
(PsErrIllegalRoleName role nearby)
-mkMDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs
-mkMDo ctxt stmts tok loc
- = mkHsDoAnns ctxt stmts (AnnList (Just loc) ListNone [] tok [])
+mkMDo :: (EpToken "{", [EpToken ";"], EpToken "}") -> HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs
+mkMDo (ob, semis, cb) ctxt stmts tok loc
+ = mkHsDoAnns ctxt stmts (AnnList (Just loc) (ListBraces ob cb) semis tok [])
-- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to
-- binders without annotations. Only accepts specified variables, and errors if
@@ -1733,7 +1733,7 @@ type AnnoBody b
, Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA
, Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA
, Anno [LocatedA (StmtLR GhcPs GhcPs
- (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnLW
+ (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnA
)
-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are
@@ -1795,8 +1795,9 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
-- | Disambiguate "do { ... }" (do notation)
mkHsDoPV ::
SrcSpan ->
+ (EpToken "{", [EpToken ";"], EpToken "}") ->
Maybe ModuleName ->
- LocatedLW [LStmt GhcPs (LocatedA b)] ->
+ LocatedA [LStmt GhcPs (LocatedA b)] ->
EpaLocation -> -- Token
EpaLocation -> -- Anchor
PV (LocatedA b)
@@ -1948,10 +1949,10 @@ instance DisambECP (HsCmd GhcPs) where
checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns)
- mkHsDoPV l Nothing stmts tok_loc anc = do
+ mkHsDoPV l (ob,semis,cb) Nothing stmts tok_loc anc = do
!cs <- getCommentsFor l
- return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) ListNone [] tok_loc []) stmts)
- mkHsDoPV l (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m
+ return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) (ListBraces ob cb) semis tok_loc []) stmts)
+ mkHsDoPV l _ (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m
mkHsParPV l lpar c rpar = do
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c)
@@ -2047,9 +2048,9 @@ instance DisambECP (HsExpr GhcPs) where
checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns)
- mkHsDoPV l mod stmts loc_tok anc = do
+ mkHsDoPV l (ob,semis,cb) mod stmts loc_tok anc = do
!cs <- getCommentsFor l
- return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) ListNone [] loc_tok []) (DoExpr mod) stmts)
+ return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) (ListBraces ob cb) semis loc_tok []) (DoExpr mod) stmts)
mkHsParPV l lpar e rpar = do
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e)
@@ -2145,7 +2146,7 @@ instance DisambECP (PatBuilder GhcPs) where
!cs <- getCommentsFor (locA l)
return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t))
mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
- mkHsDoPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
+ mkHsDoPV l _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v)
mkHsLitPV lit@(L l a) = do
=====================================
compiler/GHC/Parser/Types.hs
=====================================
@@ -110,7 +110,7 @@ instance Outputable DataConBuilder where
ppr (InfixDataConBuilder lhs data_con rhs) =
ppr lhs <+> ppr data_con <+> ppr rhs
-type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW
+type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnA
data ExplicitNamespaceKeyword
= ExplicitTypeNamespace !(EpToken "type")
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -376,7 +376,7 @@ tcGRHSNE ctxt tc_body grhss res_ty
-}
tcDoStmts :: HsDoFlavour
- -> LocatedLW [LStmt GhcRn (LHsExpr GhcRn)]
+ -> LocatedA [LStmt GhcRn (LHsExpr GhcRn)]
-> ExpRhoType
-> TcM (HsExpr GhcTc) -- Returns a HsDo
tcDoStmts ListComp (L l stmts) res_ty
=====================================
testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
=====================================
@@ -287,7 +287,9 @@
(AnnList
(Just
(EpaSpan { DumpParsedAstComments.hs:16:3 }))
- (ListNone)
+ (ListBraces
+ (NoEpTok)
+ (NoEpTok))
[]
(EpaSpan { DumpParsedAstComments.hs:14:7-8 })
[])
@@ -296,12 +298,7 @@
(L
(EpAnn
(EpaSpan { DumpParsedAstComments.hs:16:3 })
- (AnnList
- (Just
- (EpaSpan { DumpParsedAstComments.hs:16:3 }))
- (ListNone)
- []
- (NoEpTok)
+ (AnnListItem
[])
(EpaComments
[]))
=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -337,7 +337,9 @@
(AnnList
(Just
(EpaSpan { DumpSemis.hs:(11,3)-(12,3) }))
- (ListNone)
+ (ListBraces
+ (NoEpTok)
+ (NoEpTok))
[]
(EpaSpan { DumpSemis.hs:10:7-8 })
[])
@@ -346,12 +348,7 @@
(L
(EpAnn
(EpaSpan { DumpSemis.hs:(11,3)-(12,3) })
- (AnnList
- (Just
- (EpaSpan { DumpSemis.hs:(11,3)-(12,3) }))
- (ListNone)
- []
- (NoEpTok)
+ (AnnListItem
[])
(EpaComments
[]))
@@ -375,30 +372,25 @@
(AnnList
(Just
(EpaSpan { DumpSemis.hs:11:6-15 }))
- (ListNone)
- []
+ (ListBraces
+ (EpTok (EpaSpan { DumpSemis.hs:11:6 }))
+ (EpTok (EpaSpan { DumpSemis.hs:11:15 })))
+ [(EpTok
+ (EpaSpan { DumpSemis.hs:11:8 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:11:9 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:11:10 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:11:11 }))]
(EpaSpan { DumpSemis.hs:11:3-4 })
[])
(DoExpr
(Nothing))
(L
(EpAnn
- (EpaSpan { DumpSemis.hs:11:6-15 })
- (AnnList
- (Just
- (EpaSpan { DumpSemis.hs:11:8-13 }))
- (ListBraces
- (EpTok (EpaSpan { DumpSemis.hs:11:6 }))
- (EpTok (EpaSpan { DumpSemis.hs:11:15 })))
- [(EpTok
- (EpaSpan { DumpSemis.hs:11:8 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:11:9 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:11:10 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:11:11 }))]
- (NoEpTok)
+ (EpaSpan { DumpSemis.hs:11:8-13 })
+ (AnnListItem
[])
(EpaComments
[]))
@@ -649,26 +641,21 @@
(AnnList
(Just
(EpaSpan { DumpSemis.hs:(16,3)-(19,3) }))
- (ListNone)
- []
+ (ListBraces
+ (EpTok (EpaSpan { DumpSemis.hs:16:3 }))
+ (EpTok (EpaSpan { DumpSemis.hs:19:3 })))
+ [(EpTok
+ (EpaSpan { DumpSemis.hs:16:5 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:16:8 }))]
(EpaSpan { DumpSemis.hs:15:7-8 })
[])
(DoExpr
(Nothing))
(L
(EpAnn
- (EpaSpan { DumpSemis.hs:(16,3)-(19,3) })
- (AnnList
- (Just
- (EpaSpan { DumpSemis.hs:(16,5)-(18,5) }))
- (ListBraces
- (EpTok (EpaSpan { DumpSemis.hs:16:3 }))
- (EpTok (EpaSpan { DumpSemis.hs:19:3 })))
- [(EpTok
- (EpaSpan { DumpSemis.hs:16:5 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:16:8 }))]
- (NoEpTok)
+ (EpaSpan { DumpSemis.hs:(16,5)-(18,5) })
+ (AnnListItem
[])
(EpaComments
[]))
@@ -913,26 +900,21 @@
(AnnList
(Just
(EpaSpan { DumpSemis.hs:22:10-30 }))
- (ListNone)
- []
+ (ListBraces
+ (EpTok (EpaSpan { DumpSemis.hs:22:10 }))
+ (EpTok (EpaSpan { DumpSemis.hs:22:30 })))
+ [(EpTok
+ (EpaSpan { DumpSemis.hs:22:12 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:22:13 }))]
(EpaSpan { DumpSemis.hs:22:7-8 })
[])
(DoExpr
(Nothing))
(L
(EpAnn
- (EpaSpan { DumpSemis.hs:22:10-30 })
- (AnnList
- (Just
- (EpaSpan { DumpSemis.hs:22:12-28 }))
- (ListBraces
- (EpTok (EpaSpan { DumpSemis.hs:22:10 }))
- (EpTok (EpaSpan { DumpSemis.hs:22:30 })))
- [(EpTok
- (EpaSpan { DumpSemis.hs:22:12 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:22:13 }))]
- (NoEpTok)
+ (EpaSpan { DumpSemis.hs:22:12-28 })
+ (AnnListItem
[])
(EpaComments
[]))
=====================================
testsuite/tests/printer/Test20297.stdout
=====================================
@@ -390,7 +390,9 @@
(AnnList
(Just
(EpaSpan { Test20297.hs:11:22-26 }))
- (ListNone)
+ (ListBraces
+ (NoEpTok)
+ (NoEpTok))
[]
(EpaSpan { Test20297.hs:11:19-20 })
[])
@@ -399,12 +401,7 @@
(L
(EpAnn
(EpaSpan { Test20297.hs:11:22-26 })
- (AnnList
- (Just
- (EpaSpan { Test20297.hs:11:22-26 }))
- (ListNone)
- []
- (NoEpTok)
+ (AnnListItem
[])
(EpaComments
[]))
@@ -817,7 +814,9 @@
(AnnList
(Just
(EpaSpan { Test20297.ppr.hs:9:20-24 }))
- (ListNone)
+ (ListBraces
+ (NoEpTok)
+ (NoEpTok))
[]
(EpaSpan { Test20297.ppr.hs:9:17-18 })
[])
@@ -826,12 +825,7 @@
(L
(EpAnn
(EpaSpan { Test20297.ppr.hs:9:20-24 })
- (AnnList
- (Just
- (EpaSpan { Test20297.ppr.hs:9:20-24 }))
- (ListNone)
- []
- (NoEpTok)
+ (AnnListItem
[])
(EpaComments
[]))
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1447,6 +1447,8 @@ instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where
a' <- markAnnotated a
return (L la a')
+-- ---------------------------------------------------------------------
+
instance (ExactPrint a) => ExactPrint (Maybe a) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor ma _ _ _ = ma
@@ -2417,7 +2419,7 @@ exactMatch (Match an mctxt pats grhss) = do
epTokensToComments "(" opens
epTokensToComments ")" closes
fun' <- markAnnotated fun
- pats' <- mapM markAnnotated pats
+ pats' <- markAnnotated pats
return (FunRhs fun' fixity strictness (AnnFunRhs strict' [] []), pats')
Infix ->
case pats of
@@ -2438,11 +2440,11 @@ exactMatch (Match an mctxt pats grhss) = do
_ -> panic "FunRhs"
LamAlt v -> do
- pats' <- markAnnotated pats
+ pats' <- (mapM . mapM) markAnnotated pats
return (LamAlt v, pats')
CaseAlt -> do
- pats' <- markAnnotated pats
+ pats' <- (mapM . mapM) markAnnotated pats
return (CaseAlt, pats')
_ -> do
@@ -2985,7 +2987,7 @@ instance ExactPrint (HsExpr GhcPs) where
exact (HsDo an do_or_list_comp stmts) = do
debugM $ "HsDo"
- (an',stmts') <- markAnnListA' an $ \a -> exactDo a do_or_list_comp stmts
+ (an',stmts') <- exactDo an do_or_list_comp stmts
return (HsDo an' do_or_list_comp stmts')
exact (ExplicitList an es) = do
@@ -3101,9 +3103,9 @@ instance ExactPrint (HsExpr GhcPs) where
s' <- markAnnotated s
return (HsTypedSplice an s')
- exact (HsUntypedSplice an s) = do
+ exact (HsUntypedSplice x s) = do
s' <- markAnnotated s
- return (HsUntypedSplice an s')
+ return (HsUntypedSplice x s')
exact (HsProc (pr,r) p c) = do
debugM $ "HsProc start"
@@ -3160,10 +3162,12 @@ instance ExactPrint (HsExpr GhcPs) where
exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a))
=> AnnList EpaLocation -> HsDoFlavour -> LocatedAn an a
-> EP w m (AnnList EpaLocation, LocatedAn an a)
-exactDo an (DoExpr m) stmts = exactMdo an m "do" >>= \an0 -> markMaybeDodgyStmts an0 stmts
+exactDo an (DoExpr m) stmts = exactMdo an m "do" >>=
+ \an0 -> markMaybeDodgyStmts an0 stmts
exactDo an GhciStmtCtxt stmts = markLensFun an lal_rest (\l -> printStringAtAA l "do") >>=
\an0 -> markMaybeDodgyStmts an0 stmts
-exactDo an (MDoExpr m) stmts = exactMdo an m "mdo" >>= \an0 -> markMaybeDodgyStmts an0 stmts
+exactDo an (MDoExpr m) stmts = exactMdo an m "mdo" >>=
+ \an0 -> markMaybeDodgyStmts an0 stmts
exactDo an ListComp stmts = markMaybeDodgyStmts an stmts
exactDo an MonadComp stmts = markMaybeDodgyStmts an stmts
@@ -3179,8 +3183,9 @@ markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a))
markMaybeDodgyStmts an stmts =
if notDodgy stmts
then do
- r <- markAnnotatedWithLayout stmts
- return (an, r)
+ markAnnListA' an $ \a -> do
+ r <- markAnnotatedWithLayout stmts
+ return (a, r)
else return (an, stmts)
notDodgy :: GenLocated (EpAnn ann) a -> Bool
@@ -3465,19 +3470,21 @@ instance ExactPrint (HsCmd GhcPs) where
e' <- markAnnotated e
return (HsCmdLet (tkLet', tkIn') binds' e')
- exact (HsCmdDo an es) = do
+ exact (HsCmdDo an (L l es)) = do
debugM $ "HsCmdDo"
- an0 <- markLensFun an lal_rest (\l -> printStringAtAA l "do")
- es' <- markAnnotated es
- return (HsCmdDo an0 es')
+ an0 <- markLensFun an lal_rest (\ll -> printStringAtAA ll "do")
+ (an1,es') <- markAnnList' an0 $ do
+ ee <- mapM markAnnotated es
+ return ee
+ return (HsCmdDo an1 (L l es'))
-- ---------------------------------------------------------------------
instance (
ExactPrint (LocatedA (body GhcPs)),
Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA,
- Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnLW,
- (ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))])))
+ Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnA,
+ (ExactPrint (LocatedA [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))])))
=> ExactPrint (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _s = a
@@ -4524,31 +4531,36 @@ instance (ExactPrint (Match GhcPs (LocatedA body)))
an3 <- markLensBracketsC an2 lal_brackets
return (L an3 a')
-instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where
- getAnnotationEntry = entryFromLocatedA
- setAnnotationAnchor = setAnchorAn
- exact (L an stmts) = do
+instance ExactPrint [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))] where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ _ = a
+ exact stmts = do
debugM $ "LocatedL [ExprLStmt"
- (an'', stmts') <- markAnnList an $ do
- case snocView stmts of
- Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do
- debugM $ "LocatedL [ExprLStmt: snocView"
- ls' <- markAnnotated ls
- initStmts' <- mapM markAnnotated initStmts
- return (initStmts' ++ [ls'])
- _ -> do
- mapM markAnnotated stmts
- return (L an'' stmts')
-
-instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where
- getAnnotationEntry = entryFromLocatedA
- setAnnotationAnchor = setAnchorAn
- exact (L ann es) = do
- debugM $ "LocatedL [CmdLStmt"
- an0 <- markLensBracketsO ann lal_brackets
- es' <- mapM markAnnotated es
- an1 <- markLensBracketsC an0 lal_brackets
- return (L an1 es')
+ case snocView stmts of
+ Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do
+ debugM $ "LocatedL [ExprLStmt: snocView"
+ ls' <- markAnnotated ls
+ initStmts' <- markAnnotated initStmts
+ return (initStmts' ++ [ls'])
+ _ -> do
+ stmts' <- mapM markAnnotated stmts
+ return stmts'
+
+-- TODO: harmonise with prior, on payload
+instance ExactPrint [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))] where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ _ = a
+ exact stmts = do
+ debugM $ "LocatedL [ExprLStmt"
+ case snocView stmts of
+ Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do
+ debugM $ "LocatedL [ExprLStmt: snocView"
+ ls' <- markAnnotated ls
+ initStmts' <- markAnnotated initStmts
+ return (initStmts' ++ [ls'])
+ _ -> do
+ stmts' <- markAnnotated stmts
+ return stmts'
instance ExactPrint (LocatedBF (BF.BooleanFormula GhcPs)) where
getAnnotationEntry = entryFromLocatedA
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf7b5ce65f470f21eee29007f3d6a11…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf7b5ce65f470f21eee29007f3d6a11…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] 2 commits: rts: handle large AP closures in compacting GC
by Marge Bot (＠marge-bot) 30 Jun '26
by Marge Bot (＠marge-bot) 30 Jun '26
30 Jun '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
cca0d589 by Luite Stegeman at 2026-06-30T13:33:40-04:00
rts: handle large AP closures in compacting GC
The function update_fwd_large in the compacting GC could run into
an unexpected object with the following error:
internal error: update_fwd_large: unknown/strange object 24
Closure type 24 is the AP closure, which was not handled in
upd_fwd_large. This patch adds handling them.
fixes #27434
- - - - -
42935858 by Luite Stegeman at 2026-06-30T13:33:40-04:00
testsuite: use compacting_gc way instead of hardcoding +RTS -c
- - - - -
5 changed files:
- + changelog.d/fix-compacting-gc-ap-27434
- rts/sm/Compact.c
- + testsuite/tests/rts/T27434.hs
- + testsuite/tests/rts/T27434.stdout
- testsuite/tests/rts/all.T
Changes:
=====================================
changelog.d/fix-compacting-gc-ap-27434
=====================================
@@ -0,0 +1,11 @@
+section: rts
+synopsis: Fix "unknown/strange object 24 crash" in compacting GC
+issues: #27434
+mrs: !16261
+
+description {
+Fix a crash in the compacting garbage collector when collecting large
+function-application thunks. Affected programs crashed with an internal error
+of the form "update_fwd_large: unknown/strange object 24" when run with the
+compacting GC (``+RTS -c``).
+}
=====================================
rts/sm/Compact.c
=====================================
@@ -622,6 +622,10 @@ update_fwd_large( bdescr *bd )
thread_PAP((StgPAP *)p);
continue;
+ case AP:
+ thread_AP((StgAP *)p);
+ continue;
+
case TREC_CHUNK:
{
StgTRecChunk *tc = (StgTRecChunk *)p;
=====================================
testsuite/tests/rts/T27434.hs
=====================================
@@ -0,0 +1,531 @@
+
+-- This test when run under GHCi bytecode creates an AP closure whose size
+-- exceeds LARGE_OBJECT_THRESHOLD. The compacting GC didn't handle these.
+
+module Main where
+
+import System.Mem (performMajorGC)
+import Control.Monad (forM_)
+import Data.IORef
+
+data Box = Box Int
+
+{-# NOINLINE bigfun #-}
+bigfun :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+bigfun a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32 a33 a34 a35 a36 a37 a38 a39 a40 a41 a42 a43 a44 a45 a46 a47 a48 a49 a50 a51 a52 a53 a54 a55 a56 a57 a58 a59 a60 a61 a62 a63 a64 a65 a66 a67 a68 a69 a70 a71 a72 a73 a74 a75 a76 a77 a78 a79 a80 a81 a82 a83 a84 a85 a86 a87 a88 a89 a90 a91 a92 a93 a94 a95 a96 a97 a98 a99 a100 a101 a102 a103 a104 a105 a106 a107 a108 a109 a110 a111 a112 a113 a114 a115 a116 a117 a118 a119 a120 a121 a122 a123 a124 a125 a126 a127 a128 a129 a130 a131 a132 a133 a134 a135 a136 a137 a138 a139 a140 a141 a142 a143 a144 a145 a146 a147 a148 a149 a150 a151 a152 a153 a154 a155 a156 a157 a158 a159 a160 a161 a162 a163 a164 a165 a166 a167 a168 a169 a170 a171 a172 a173 a174 a175 a176 a177 a178 a179 a180 a181 a182 a183 a184 a185 a186 a187 a188 a189 a190 a191 a192 a193 a194 a195 a196 a197 a198 a199 a200 a201 a202 a203 a204 a205 a206 a207 a208 a209 a210 a211 a212 a213 a214 a215 a216 a217 a218 a219 a220 a221 a222 a223 a224 a225 a226 a227 a228 a229 a230 a231 a232 a233 a234 a235 a236 a237 a238 a239 a240 a241 a242 a243 a244 a245 a246 a247 a248 a249 a250 a251 a252 a253 a254 a255 a256 a257 a258 a259 a260 a261 a262 a263 a264 a265 a266 a267 a268 a269 a270 a271 a272 a273 a274 a275 a276 a277 a278 a279 a280 a281 a282 a283 a284 a285 a286 a287 a288 a289 a290 a291 a292 a293 a294 a295 a296 a297 a298 a299 a300 a301 a302 a303 a304 a305 a306 a307 a308 a309 a310 a311 a312 a313 a314 a315 a316 a317 a318 a319 a320 a321 a322 a323 a324 a325 a326 a327 a328 a329 a330 a331 a332 a333 a334 a335 a336 a337 a338 a339 a340 a341 a342 a343 a344 a345 a346 a347 a348 a349 a350 a351 a352 a353 a354 a355 a356 a357 a358 a359 a360 a361 a362 a363 a364 a365 a366 a367 a368 a369 a370 a371 a372 a373 a374 a375 a376 a377 a378 a379 a380 a381 a382 a383 a384 a385 a386 a387 a388 a389 a390 a391 a392 a393 a394 a395 a396 a397 a398 a399 a400 a401 a402 a403 a404 a405 a406 a407 a408 a409 a410 a411 a412 a413 a414 a415 a416 a417 a418 a419 a420 a421 a422 a423 a424 a425 a426 a427 a428 a429 a430 a431 a432 a433 a434 a435 a436 a437 a438 a439 a440 a441 a442 a443 a444 a445 a446 a447 a448 a449 a450 a451 a452 a453 a454 a455 a456 a457 a458 a459 a460 a461 a462 a463 a464 a465 a466 a467 a468 a469 a470 a471 a472 a473 a474 a475 a476 a477 a478 a479 a480 a481 a482 a483 a484 a485 a486 a487 a488 a489 a490 a491 a492 a493 a494 a495 a496 a497 a498 a499 = a0+a1+a2+a3+a4+a5+a6+a7+a8+a9+a10+a11+a12+a13+a14+a15+a16+a17+a18+a19+a20+a21+a22+a23+a24+a25+a26+a27+a28+a29+a30+a31+a32+a33+a34+a35+a36+a37+a38+a39+a40+a41+a42+a43+a44+a45+a46+a47+a48+a49+a50+a51+a52+a53+a54+a55+a56+a57+a58+a59+a60+a61+a62+a63+a64+a65+a66+a67+a68+a69+a70+a71+a72+a73+a74+a75+a76+a77+a78+a79+a80+a81+a82+a83+a84+a85+a86+a87+a88+a89+a90+a91+a92+a93+a94+a95+a96+a97+a98+a99+a100+a101+a102+a103+a104+a105+a106+a107+a108+a109+a110+a111+a112+a113+a114+a115+a116+a117+a118+a119+a120+a121+a122+a123+a124+a125+a126+a127+a128+a129+a130+a131+a132+a133+a134+a135+a136+a137+a138+a139+a140+a141+a142+a143+a144+a145+a146+a147+a148+a149+a150+a151+a152+a153+a154+a155+a156+a157+a158+a159+a160+a161+a162+a163+a164+a165+a166+a167+a168+a169+a170+a171+a172+a173+a174+a175+a176+a177+a178+a179+a180+a181+a182+a183+a184+a185+a186+a187+a188+a189+a190+a191+a192+a193+a194+a195+a196+a197+a198+a199+a200+a201+a202+a203+a204+a205+a206+a207+a208+a209+a210+a211+a212+a213+a214+a215+a216+a217+a218+a219+a220+a221+a222+a223+a224+a225+a226+a227+a228+a229+a230+a231+a232+a233+a234+a235+a236+a237+a238+a239+a240+a241+a242+a243+a244+a245+a246+a247+a248+a249+a250+a251+a252+a253+a254+a255+a256+a257+a258+a259+a260+a261+a262+a263+a264+a265+a266+a267+a268+a269+a270+a271+a272+a273+a274+a275+a276+a277+a278+a279+a280+a281+a282+a283+a284+a285+a286+a287+a288+a289+a290+a291+a292+a293+a294+a295+a296+a297+a298+a299+a300+a301+a302+a303+a304+a305+a306+a307+a308+a309+a310+a311+a312+a313+a314+a315+a316+a317+a318+a319+a320+a321+a322+a323+a324+a325+a326+a327+a328+a329+a330+a331+a332+a333+a334+a335+a336+a337+a338+a339+a340+a341+a342+a343+a344+a345+a346+a347+a348+a349+a350+a351+a352+a353+a354+a355+a356+a357+a358+a359+a360+a361+a362+a363+a364+a365+a366+a367+a368+a369+a370+a371+a372+a373+a374+a375+a376+a377+a378+a379+a380+a381+a382+a383+a384+a385+a386+a387+a388+a389+a390+a391+a392+a393+a394+a395+a396+a397+a398+a399+a400+a401+a402+a403+a404+a405+a406+a407+a408+a409+a410+a411+a412+a413+a414+a415+a416+a417+a418+a419+a420+a421+a422+a423+a424+a425+a426+a427+a428+a429+a430+a431+a432+a433+a434+a435+a436+a437+a438+a439+a440+a441+a442+a443+a444+a445+a446+a447+a448+a449+a450+a451+a452+a453+a454+a455+a456+a457+a458+a459+a460+a461+a462+a463+a464+a465+a466+a467+a468+a469+a470+a471+a472+a473+a474+a475+a476+a477+a478+a479+a480+a481+a482+a483+a484+a485+a486+a487+a488+a489+a490+a491+a492+a493+a494+a495+a496+a497+a498+a499
+
+{-# NOINLINE mkBox #-}
+mkBox :: Int -> Box
+mkBox seed =
+ let v0 = seed + 0 in
+ let v1 = seed + 1 in
+ let v2 = seed + 2 in
+ let v3 = seed + 3 in
+ let v4 = seed + 4 in
+ let v5 = seed + 5 in
+ let v6 = seed + 6 in
+ let v7 = seed + 7 in
+ let v8 = seed + 8 in
+ let v9 = seed + 9 in
+ let v10 = seed + 10 in
+ let v11 = seed + 11 in
+ let v12 = seed + 12 in
+ let v13 = seed + 13 in
+ let v14 = seed + 14 in
+ let v15 = seed + 15 in
+ let v16 = seed + 16 in
+ let v17 = seed + 17 in
+ let v18 = seed + 18 in
+ let v19 = seed + 19 in
+ let v20 = seed + 20 in
+ let v21 = seed + 21 in
+ let v22 = seed + 22 in
+ let v23 = seed + 23 in
+ let v24 = seed + 24 in
+ let v25 = seed + 25 in
+ let v26 = seed + 26 in
+ let v27 = seed + 27 in
+ let v28 = seed + 28 in
+ let v29 = seed + 29 in
+ let v30 = seed + 30 in
+ let v31 = seed + 31 in
+ let v32 = seed + 32 in
+ let v33 = seed + 33 in
+ let v34 = seed + 34 in
+ let v35 = seed + 35 in
+ let v36 = seed + 36 in
+ let v37 = seed + 37 in
+ let v38 = seed + 38 in
+ let v39 = seed + 39 in
+ let v40 = seed + 40 in
+ let v41 = seed + 41 in
+ let v42 = seed + 42 in
+ let v43 = seed + 43 in
+ let v44 = seed + 44 in
+ let v45 = seed + 45 in
+ let v46 = seed + 46 in
+ let v47 = seed + 47 in
+ let v48 = seed + 48 in
+ let v49 = seed + 49 in
+ let v50 = seed + 50 in
+ let v51 = seed + 51 in
+ let v52 = seed + 52 in
+ let v53 = seed + 53 in
+ let v54 = seed + 54 in
+ let v55 = seed + 55 in
+ let v56 = seed + 56 in
+ let v57 = seed + 57 in
+ let v58 = seed + 58 in
+ let v59 = seed + 59 in
+ let v60 = seed + 60 in
+ let v61 = seed + 61 in
+ let v62 = seed + 62 in
+ let v63 = seed + 63 in
+ let v64 = seed + 64 in
+ let v65 = seed + 65 in
+ let v66 = seed + 66 in
+ let v67 = seed + 67 in
+ let v68 = seed + 68 in
+ let v69 = seed + 69 in
+ let v70 = seed + 70 in
+ let v71 = seed + 71 in
+ let v72 = seed + 72 in
+ let v73 = seed + 73 in
+ let v74 = seed + 74 in
+ let v75 = seed + 75 in
+ let v76 = seed + 76 in
+ let v77 = seed + 77 in
+ let v78 = seed + 78 in
+ let v79 = seed + 79 in
+ let v80 = seed + 80 in
+ let v81 = seed + 81 in
+ let v82 = seed + 82 in
+ let v83 = seed + 83 in
+ let v84 = seed + 84 in
+ let v85 = seed + 85 in
+ let v86 = seed + 86 in
+ let v87 = seed + 87 in
+ let v88 = seed + 88 in
+ let v89 = seed + 89 in
+ let v90 = seed + 90 in
+ let v91 = seed + 91 in
+ let v92 = seed + 92 in
+ let v93 = seed + 93 in
+ let v94 = seed + 94 in
+ let v95 = seed + 95 in
+ let v96 = seed + 96 in
+ let v97 = seed + 97 in
+ let v98 = seed + 98 in
+ let v99 = seed + 99 in
+ let v100 = seed + 100 in
+ let v101 = seed + 101 in
+ let v102 = seed + 102 in
+ let v103 = seed + 103 in
+ let v104 = seed + 104 in
+ let v105 = seed + 105 in
+ let v106 = seed + 106 in
+ let v107 = seed + 107 in
+ let v108 = seed + 108 in
+ let v109 = seed + 109 in
+ let v110 = seed + 110 in
+ let v111 = seed + 111 in
+ let v112 = seed + 112 in
+ let v113 = seed + 113 in
+ let v114 = seed + 114 in
+ let v115 = seed + 115 in
+ let v116 = seed + 116 in
+ let v117 = seed + 117 in
+ let v118 = seed + 118 in
+ let v119 = seed + 119 in
+ let v120 = seed + 120 in
+ let v121 = seed + 121 in
+ let v122 = seed + 122 in
+ let v123 = seed + 123 in
+ let v124 = seed + 124 in
+ let v125 = seed + 125 in
+ let v126 = seed + 126 in
+ let v127 = seed + 127 in
+ let v128 = seed + 128 in
+ let v129 = seed + 129 in
+ let v130 = seed + 130 in
+ let v131 = seed + 131 in
+ let v132 = seed + 132 in
+ let v133 = seed + 133 in
+ let v134 = seed + 134 in
+ let v135 = seed + 135 in
+ let v136 = seed + 136 in
+ let v137 = seed + 137 in
+ let v138 = seed + 138 in
+ let v139 = seed + 139 in
+ let v140 = seed + 140 in
+ let v141 = seed + 141 in
+ let v142 = seed + 142 in
+ let v143 = seed + 143 in
+ let v144 = seed + 144 in
+ let v145 = seed + 145 in
+ let v146 = seed + 146 in
+ let v147 = seed + 147 in
+ let v148 = seed + 148 in
+ let v149 = seed + 149 in
+ let v150 = seed + 150 in
+ let v151 = seed + 151 in
+ let v152 = seed + 152 in
+ let v153 = seed + 153 in
+ let v154 = seed + 154 in
+ let v155 = seed + 155 in
+ let v156 = seed + 156 in
+ let v157 = seed + 157 in
+ let v158 = seed + 158 in
+ let v159 = seed + 159 in
+ let v160 = seed + 160 in
+ let v161 = seed + 161 in
+ let v162 = seed + 162 in
+ let v163 = seed + 163 in
+ let v164 = seed + 164 in
+ let v165 = seed + 165 in
+ let v166 = seed + 166 in
+ let v167 = seed + 167 in
+ let v168 = seed + 168 in
+ let v169 = seed + 169 in
+ let v170 = seed + 170 in
+ let v171 = seed + 171 in
+ let v172 = seed + 172 in
+ let v173 = seed + 173 in
+ let v174 = seed + 174 in
+ let v175 = seed + 175 in
+ let v176 = seed + 176 in
+ let v177 = seed + 177 in
+ let v178 = seed + 178 in
+ let v179 = seed + 179 in
+ let v180 = seed + 180 in
+ let v181 = seed + 181 in
+ let v182 = seed + 182 in
+ let v183 = seed + 183 in
+ let v184 = seed + 184 in
+ let v185 = seed + 185 in
+ let v186 = seed + 186 in
+ let v187 = seed + 187 in
+ let v188 = seed + 188 in
+ let v189 = seed + 189 in
+ let v190 = seed + 190 in
+ let v191 = seed + 191 in
+ let v192 = seed + 192 in
+ let v193 = seed + 193 in
+ let v194 = seed + 194 in
+ let v195 = seed + 195 in
+ let v196 = seed + 196 in
+ let v197 = seed + 197 in
+ let v198 = seed + 198 in
+ let v199 = seed + 199 in
+ let v200 = seed + 200 in
+ let v201 = seed + 201 in
+ let v202 = seed + 202 in
+ let v203 = seed + 203 in
+ let v204 = seed + 204 in
+ let v205 = seed + 205 in
+ let v206 = seed + 206 in
+ let v207 = seed + 207 in
+ let v208 = seed + 208 in
+ let v209 = seed + 209 in
+ let v210 = seed + 210 in
+ let v211 = seed + 211 in
+ let v212 = seed + 212 in
+ let v213 = seed + 213 in
+ let v214 = seed + 214 in
+ let v215 = seed + 215 in
+ let v216 = seed + 216 in
+ let v217 = seed + 217 in
+ let v218 = seed + 218 in
+ let v219 = seed + 219 in
+ let v220 = seed + 220 in
+ let v221 = seed + 221 in
+ let v222 = seed + 222 in
+ let v223 = seed + 223 in
+ let v224 = seed + 224 in
+ let v225 = seed + 225 in
+ let v226 = seed + 226 in
+ let v227 = seed + 227 in
+ let v228 = seed + 228 in
+ let v229 = seed + 229 in
+ let v230 = seed + 230 in
+ let v231 = seed + 231 in
+ let v232 = seed + 232 in
+ let v233 = seed + 233 in
+ let v234 = seed + 234 in
+ let v235 = seed + 235 in
+ let v236 = seed + 236 in
+ let v237 = seed + 237 in
+ let v238 = seed + 238 in
+ let v239 = seed + 239 in
+ let v240 = seed + 240 in
+ let v241 = seed + 241 in
+ let v242 = seed + 242 in
+ let v243 = seed + 243 in
+ let v244 = seed + 244 in
+ let v245 = seed + 245 in
+ let v246 = seed + 246 in
+ let v247 = seed + 247 in
+ let v248 = seed + 248 in
+ let v249 = seed + 249 in
+ let v250 = seed + 250 in
+ let v251 = seed + 251 in
+ let v252 = seed + 252 in
+ let v253 = seed + 253 in
+ let v254 = seed + 254 in
+ let v255 = seed + 255 in
+ let v256 = seed + 256 in
+ let v257 = seed + 257 in
+ let v258 = seed + 258 in
+ let v259 = seed + 259 in
+ let v260 = seed + 260 in
+ let v261 = seed + 261 in
+ let v262 = seed + 262 in
+ let v263 = seed + 263 in
+ let v264 = seed + 264 in
+ let v265 = seed + 265 in
+ let v266 = seed + 266 in
+ let v267 = seed + 267 in
+ let v268 = seed + 268 in
+ let v269 = seed + 269 in
+ let v270 = seed + 270 in
+ let v271 = seed + 271 in
+ let v272 = seed + 272 in
+ let v273 = seed + 273 in
+ let v274 = seed + 274 in
+ let v275 = seed + 275 in
+ let v276 = seed + 276 in
+ let v277 = seed + 277 in
+ let v278 = seed + 278 in
+ let v279 = seed + 279 in
+ let v280 = seed + 280 in
+ let v281 = seed + 281 in
+ let v282 = seed + 282 in
+ let v283 = seed + 283 in
+ let v284 = seed + 284 in
+ let v285 = seed + 285 in
+ let v286 = seed + 286 in
+ let v287 = seed + 287 in
+ let v288 = seed + 288 in
+ let v289 = seed + 289 in
+ let v290 = seed + 290 in
+ let v291 = seed + 291 in
+ let v292 = seed + 292 in
+ let v293 = seed + 293 in
+ let v294 = seed + 294 in
+ let v295 = seed + 295 in
+ let v296 = seed + 296 in
+ let v297 = seed + 297 in
+ let v298 = seed + 298 in
+ let v299 = seed + 299 in
+ let v300 = seed + 300 in
+ let v301 = seed + 301 in
+ let v302 = seed + 302 in
+ let v303 = seed + 303 in
+ let v304 = seed + 304 in
+ let v305 = seed + 305 in
+ let v306 = seed + 306 in
+ let v307 = seed + 307 in
+ let v308 = seed + 308 in
+ let v309 = seed + 309 in
+ let v310 = seed + 310 in
+ let v311 = seed + 311 in
+ let v312 = seed + 312 in
+ let v313 = seed + 313 in
+ let v314 = seed + 314 in
+ let v315 = seed + 315 in
+ let v316 = seed + 316 in
+ let v317 = seed + 317 in
+ let v318 = seed + 318 in
+ let v319 = seed + 319 in
+ let v320 = seed + 320 in
+ let v321 = seed + 321 in
+ let v322 = seed + 322 in
+ let v323 = seed + 323 in
+ let v324 = seed + 324 in
+ let v325 = seed + 325 in
+ let v326 = seed + 326 in
+ let v327 = seed + 327 in
+ let v328 = seed + 328 in
+ let v329 = seed + 329 in
+ let v330 = seed + 330 in
+ let v331 = seed + 331 in
+ let v332 = seed + 332 in
+ let v333 = seed + 333 in
+ let v334 = seed + 334 in
+ let v335 = seed + 335 in
+ let v336 = seed + 336 in
+ let v337 = seed + 337 in
+ let v338 = seed + 338 in
+ let v339 = seed + 339 in
+ let v340 = seed + 340 in
+ let v341 = seed + 341 in
+ let v342 = seed + 342 in
+ let v343 = seed + 343 in
+ let v344 = seed + 344 in
+ let v345 = seed + 345 in
+ let v346 = seed + 346 in
+ let v347 = seed + 347 in
+ let v348 = seed + 348 in
+ let v349 = seed + 349 in
+ let v350 = seed + 350 in
+ let v351 = seed + 351 in
+ let v352 = seed + 352 in
+ let v353 = seed + 353 in
+ let v354 = seed + 354 in
+ let v355 = seed + 355 in
+ let v356 = seed + 356 in
+ let v357 = seed + 357 in
+ let v358 = seed + 358 in
+ let v359 = seed + 359 in
+ let v360 = seed + 360 in
+ let v361 = seed + 361 in
+ let v362 = seed + 362 in
+ let v363 = seed + 363 in
+ let v364 = seed + 364 in
+ let v365 = seed + 365 in
+ let v366 = seed + 366 in
+ let v367 = seed + 367 in
+ let v368 = seed + 368 in
+ let v369 = seed + 369 in
+ let v370 = seed + 370 in
+ let v371 = seed + 371 in
+ let v372 = seed + 372 in
+ let v373 = seed + 373 in
+ let v374 = seed + 374 in
+ let v375 = seed + 375 in
+ let v376 = seed + 376 in
+ let v377 = seed + 377 in
+ let v378 = seed + 378 in
+ let v379 = seed + 379 in
+ let v380 = seed + 380 in
+ let v381 = seed + 381 in
+ let v382 = seed + 382 in
+ let v383 = seed + 383 in
+ let v384 = seed + 384 in
+ let v385 = seed + 385 in
+ let v386 = seed + 386 in
+ let v387 = seed + 387 in
+ let v388 = seed + 388 in
+ let v389 = seed + 389 in
+ let v390 = seed + 390 in
+ let v391 = seed + 391 in
+ let v392 = seed + 392 in
+ let v393 = seed + 393 in
+ let v394 = seed + 394 in
+ let v395 = seed + 395 in
+ let v396 = seed + 396 in
+ let v397 = seed + 397 in
+ let v398 = seed + 398 in
+ let v399 = seed + 399 in
+ let v400 = seed + 400 in
+ let v401 = seed + 401 in
+ let v402 = seed + 402 in
+ let v403 = seed + 403 in
+ let v404 = seed + 404 in
+ let v405 = seed + 405 in
+ let v406 = seed + 406 in
+ let v407 = seed + 407 in
+ let v408 = seed + 408 in
+ let v409 = seed + 409 in
+ let v410 = seed + 410 in
+ let v411 = seed + 411 in
+ let v412 = seed + 412 in
+ let v413 = seed + 413 in
+ let v414 = seed + 414 in
+ let v415 = seed + 415 in
+ let v416 = seed + 416 in
+ let v417 = seed + 417 in
+ let v418 = seed + 418 in
+ let v419 = seed + 419 in
+ let v420 = seed + 420 in
+ let v421 = seed + 421 in
+ let v422 = seed + 422 in
+ let v423 = seed + 423 in
+ let v424 = seed + 424 in
+ let v425 = seed + 425 in
+ let v426 = seed + 426 in
+ let v427 = seed + 427 in
+ let v428 = seed + 428 in
+ let v429 = seed + 429 in
+ let v430 = seed + 430 in
+ let v431 = seed + 431 in
+ let v432 = seed + 432 in
+ let v433 = seed + 433 in
+ let v434 = seed + 434 in
+ let v435 = seed + 435 in
+ let v436 = seed + 436 in
+ let v437 = seed + 437 in
+ let v438 = seed + 438 in
+ let v439 = seed + 439 in
+ let v440 = seed + 440 in
+ let v441 = seed + 441 in
+ let v442 = seed + 442 in
+ let v443 = seed + 443 in
+ let v444 = seed + 444 in
+ let v445 = seed + 445 in
+ let v446 = seed + 446 in
+ let v447 = seed + 447 in
+ let v448 = seed + 448 in
+ let v449 = seed + 449 in
+ let v450 = seed + 450 in
+ let v451 = seed + 451 in
+ let v452 = seed + 452 in
+ let v453 = seed + 453 in
+ let v454 = seed + 454 in
+ let v455 = seed + 455 in
+ let v456 = seed + 456 in
+ let v457 = seed + 457 in
+ let v458 = seed + 458 in
+ let v459 = seed + 459 in
+ let v460 = seed + 460 in
+ let v461 = seed + 461 in
+ let v462 = seed + 462 in
+ let v463 = seed + 463 in
+ let v464 = seed + 464 in
+ let v465 = seed + 465 in
+ let v466 = seed + 466 in
+ let v467 = seed + 467 in
+ let v468 = seed + 468 in
+ let v469 = seed + 469 in
+ let v470 = seed + 470 in
+ let v471 = seed + 471 in
+ let v472 = seed + 472 in
+ let v473 = seed + 473 in
+ let v474 = seed + 474 in
+ let v475 = seed + 475 in
+ let v476 = seed + 476 in
+ let v477 = seed + 477 in
+ let v478 = seed + 478 in
+ let v479 = seed + 479 in
+ let v480 = seed + 480 in
+ let v481 = seed + 481 in
+ let v482 = seed + 482 in
+ let v483 = seed + 483 in
+ let v484 = seed + 484 in
+ let v485 = seed + 485 in
+ let v486 = seed + 486 in
+ let v487 = seed + 487 in
+ let v488 = seed + 488 in
+ let v489 = seed + 489 in
+ let v490 = seed + 490 in
+ let v491 = seed + 491 in
+ let v492 = seed + 492 in
+ let v493 = seed + 493 in
+ let v494 = seed + 494 in
+ let v495 = seed + 495 in
+ let v496 = seed + 496 in
+ let v497 = seed + 497 in
+ let v498 = seed + 498 in
+ let v499 = seed + 499 in
+ Box (bigfun v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16 v17 v18 v19 v20 v21 v22 v23 v24 v25 v26 v27 v28 v29 v30 v31 v32 v33 v34 v35 v36 v37 v38 v39 v40 v41 v42 v43 v44 v45 v46 v47 v48 v49 v50 v51 v52 v53 v54 v55 v56 v57 v58 v59 v60 v61 v62 v63 v64 v65 v66 v67 v68 v69 v70 v71 v72 v73 v74 v75 v76 v77 v78 v79 v80 v81 v82 v83 v84 v85 v86 v87 v88 v89 v90 v91 v92 v93 v94 v95 v96 v97 v98 v99 v100 v101 v102 v103 v104 v105 v106 v107 v108 v109 v110 v111 v112 v113 v114 v115 v116 v117 v118 v119 v120 v121 v122 v123 v124 v125 v126 v127 v128 v129 v130 v131 v132 v133 v134 v135 v136 v137 v138 v139 v140 v141 v142 v143 v144 v145 v146 v147 v148 v149 v150 v151 v152 v153 v154 v155 v156 v157 v158 v159 v160 v161 v162 v163 v164 v165 v166 v167 v168 v169 v170 v171 v172 v173 v174 v175 v176 v177 v178 v179 v180 v181 v182 v183 v184 v185 v186 v187 v188 v189 v190 v191 v192 v193 v194 v195 v196 v197 v198 v199 v200 v201 v202 v203 v204 v205 v206 v207 v208 v209 v210 v211 v212 v213 v214 v215 v216 v217 v218 v219 v220 v221 v222 v223 v224 v225 v226 v227 v228 v229 v230 v231 v232 v233 v234 v235 v236 v237 v238 v239 v240 v241 v242 v243 v244 v245 v246 v247 v248 v249 v250 v251 v252 v253 v254 v255 v256 v257 v258 v259 v260 v261 v262 v263 v264 v265 v266 v267 v268 v269 v270 v271 v272 v273 v274 v275 v276 v277 v278 v279 v280 v281 v282 v283 v284 v285 v286 v287 v288 v289 v290 v291 v292 v293 v294 v295 v296 v297 v298 v299 v300 v301 v302 v303 v304 v305 v306 v307 v308 v309 v310 v311 v312 v313 v314 v315 v316 v317 v318 v319 v320 v321 v322 v323 v324 v325 v326 v327 v328 v329 v330 v331 v332 v333 v334 v335 v336 v337 v338 v339 v340 v341 v342 v343 v344 v345 v346 v347 v348 v349 v350 v351 v352 v353 v354 v355 v356 v357 v358 v359 v360 v361 v362 v363 v364 v365 v366 v367 v368 v369 v370 v371 v372 v373 v374 v375 v376 v377 v378 v379 v380 v381 v382 v383 v384 v385 v386 v387 v388 v389 v390 v391 v392 v393 v394 v395 v396 v397 v398 v399 v400 v401 v402 v403 v404 v405 v406 v407 v408 v409 v410 v411 v412 v413 v414 v415 v416 v417 v418 v419 v420 v421 v422 v423 v424 v425 v426 v427 v428 v429 v430 v431 v432 v433 v434 v435 v436 v437 v438 v439 v440 v441 v442 v443 v444 v445 v446 v447 v448 v449 v450 v451 v452 v453 v454 v455 v456 v457 v458 v459 v460 v461 v462 v463 v464 v465 v466 v467 v468 v469 v470 v471 v472 v473 v474 v475 v476 v477 v478 v479 v480 v481 v482 v483 v484 v485 v486 v487 v488 v489 v490 v491 v492 v493 v494 v495 v496 v497 v498 v499)
+
+main :: IO ()
+main = do
+ ref <- newIORef ([] :: [Box])
+ forM_ [1..100] $ \s -> do
+ let b = mkBox s
+ b `seq` modifyIORef' ref (b:)
+ performMajorGC
+ performMajorGC
+ bs <- readIORef ref
+ print (sum [ x | Box x <- bs ])
=====================================
testsuite/tests/rts/T27434.stdout
=====================================
@@ -0,0 +1 @@
+15000000
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -19,9 +19,8 @@ test('testmblockalloc',
# See bug #101, test requires +RTS -c (or equivalently +RTS -M<something>)
# only GHCi triggers the bug, but we run the test all ways for completeness.
test('bug1010',
- # Non-moving GC doesn't support -c
- omit_ways(['nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc']),
- compile_and_run, ['+RTS -c -RTS'])
+ extra_ways(['compacting_gc']),
+ compile_and_run, [''])
def normalise_address(str):
return re.sub('Access violation in generated code when reading [0]+',
@@ -122,10 +121,8 @@ test('outofmem2',
test('T2047',
[ignore_stdout,
- extra_run_opts('+RTS -c -RTS'),
when(opsys('freebsd'), fragile(25751)),
- # Non-moving collector doesn't support -c
- omit_ways(['nonmoving', 'nonmoving_thr', 'nonmoving_thr_sanity', 'nonmoving_thr_ghc'])],
+ extra_ways(['compacting_gc'])],
compile_and_run, ['-package containers'])
# Blackhole-detection test.
@@ -449,14 +446,11 @@ test('T13832', [exit_code(1), req_ghc_with_threaded_rts], compile_and_run, ['-th
test('T13894', js_skip, compile_and_run, [''])
# this test fails with the profasm way on some machines but not others,
# so we just skip it.
-test('T14497', [omit_ways(['profasm']), multi_cpu_race], compile_and_run, ['-O'])
-# The issue in the above test also happened with compaction enabled.
-test('T14497-compact',
- [ extra_files(['T14497.hs'])
- , only_ways(['normal'])
+test('T14497', [ omit_ways(['profasm'])
+ , extra_ways(['compacting_gc'])
, multi_cpu_race
- , extra_run_opts('+RTS -c -RTS')
- ] , compile_and_run, ['-O'])
+ ]
+ , compile_and_run, ['-O'])
test('T14695', [js_broken(22359), ignore_stderr], makefile_test, ['T14695'])
test('T14702', [ ignore_stdout
, when(unregisterised(), skip)
@@ -546,7 +540,7 @@ test('RestartEventLogging',
compile_and_run, ['RestartEventLogging_c.c'])
test('T17088',
- [only_ways(['normal']), extra_run_opts('+RTS -c -A256k -RTS')],
+ [extra_ways(['compacting_gc']), extra_run_opts('+RTS -A256k -RTS')],
compile_and_run, ['-rtsopts -O2'])
test('T15427', js_broken(22374), compile_and_run, [''])
@@ -687,3 +681,7 @@ test('ClosureTable',
['-debug -O0 ClosureTable_c.c -I{top}/../rts -I{top}/../rts/include'])
test('resizeMutableByteArrayInPlace', [req_cmm, extra_ways(['optasm', 'sanity']), only_ways(['optasm', 'sanity'])], compile_and_run, [''])
+
+test('T27434',
+ extra_ways(['compacting_gc']),
+ compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2d0fd154fc10fe00974ea2a1f0b508…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2d0fd154fc10fe00974ea2a1f0b508…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/no-code-output-constr] 2 commits: Add 'backendInfoTableMapValidity' backend predicate
by Hannes Siebenhandl (＠fendor) 30 Jun '26
by Hannes Siebenhandl (＠fendor) 30 Jun '26
30 Jun '26
Hannes Siebenhandl pushed to branch wip/fendor/no-code-output-constr at Glasgow Haskell Compiler / GHC
Commits:
ac1e02d9 by fendor at 2026-06-30T17:47:59+02:00
Add 'backendInfoTableMapValidity' backend predicate
Check whether the backend supports the `-finfo-table-map` flag and
ignore it otherwise.
Improve by-design documentation of `backendCodeOutput`.
`Backend` is **abstract by design**. Make this clearer in
`backendCodeOutput` which is incorrectly being used as a proxy for
`Backend`.
Instead, define the desired property predicates in GHC.Driver.Backend
In the process, make `backendCodeOutput` total.
- - - - -
dc19fa5e by fendor at 2026-06-30T17:47:59+02:00
Add failing test for `-finfo-table-map` and bytecode backend
If you compile a module using the bytecode backend, with
-finfo-table-map, then the info table map doesn't get populated for the
module.
This is because the -finfo-table-map code path is implemented mostly in
the StgToCmm phase which isn't run when creating bytecode.
Ticket #27039
- - - - -
10 changed files:
- compiler/GHC/Driver/Backend.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Main/Compile.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Session.hs
- testsuite/tests/ghci/scripts/all.T
- + testsuite/tests/ghci/scripts/bytecodeIPE.hs
- + testsuite/tests/ghci/scripts/bytecodeIPE.script
- + testsuite/tests/ghci/scripts/bytecodeIPE.stderr
- + testsuite/tests/ghci/scripts/bytecodeIPE.stdout
Changes:
=====================================
compiler/GHC/Driver/Backend.hs
=====================================
@@ -99,6 +99,7 @@ module GHC.Driver.Backend
, backendPostHscPipeline
, backendNormalSuccessorPhase
, backendName
+ , backendInfoTableMapValidity
, backendValidityOfCImport
, backendValidityOfCExport
@@ -117,7 +118,6 @@ import GHC.Driver.Phases
import GHC.Utils.Error
-import GHC.Utils.Panic
import GHC.Driver.Pipeline.Monad
import GHC.Platform
@@ -368,7 +368,8 @@ data PrimitiveImplementation
-- We expect one function per back end—or more precisely, one function
-- for each back end that writes code to a file. (The interpreter
-- does not write to files; its output lives only in memory.)
-
+--
+-- See Note [Backend Defunctionalization]
data DefunctionalizedCodeOutput
= NcgCodeOutput
| ViaCCodeOutput
@@ -680,6 +681,18 @@ backendSupportsBreakpoints = \case
Named Bytecode -> True
Named NoBackend -> False
+-- | Return is 'IsValid' if the backend supports @-finfo-table-map@.
+-- If 'backendInfoTableMapValidity' returns 'NotValid', then the driver ignores
+-- the flag @-finfo-table-map@, since the backend doesn't support generating
+-- the info table map.
+backendInfoTableMapValidity :: Backend -> Validity' String
+backendInfoTableMapValidity (Named NCG) = IsValid
+backendInfoTableMapValidity (Named LLVM) = NotValid "-finfo-table-map is incompatible with -fllvm and is disabled (See #26435)"
+backendInfoTableMapValidity (Named ViaC) = IsValid
+backendInfoTableMapValidity (Named JavaScript) = NotValid "-finfo-table-map is incompatible with the javascript backend"
+backendInfoTableMapValidity (Named Bytecode) = NotValid "-finfo-table-map is incompatible with -fbyte-code and is disabled"
+backendInfoTableMapValidity (Named NoBackend) = IsValid -- We are not generating code, so we ignore it any way
+
-- | If this flag is set, then the driver forces the
-- optimization level to 0, issuing a warning message if
-- the command line requested a higher optimization level.
@@ -768,20 +781,33 @@ backendCDefs (Named NoBackend) = NoCDefs
-- > -> Set UnitId -- ^ dependencies
-- > -> Stream IO RawCmmGroup a -- results from `StgToCmm`
-- > -> IO a
-backendCodeOutput :: Backend -> DefunctionalizedCodeOutput
-backendCodeOutput (Named NCG) = NcgCodeOutput
-backendCodeOutput (Named LLVM) = LlvmCodeOutput
-backendCodeOutput (Named ViaC) = ViaCCodeOutput
-backendCodeOutput (Named JavaScript) = JSCodeOutput
-backendCodeOutput (Named Bytecode) = panic "backendCodeOutput: bytecodeBackend"
-backendCodeOutput (Named NoBackend) = panic "backendCodeOutput: noBackend"
+--
+-- See Note [Backend Defunctionalization]
+--
+-- === __WARNING__
+--
+-- Do NOT use 'backendCodeOutput' (or other functions in this module) as a
+-- proxy for the 'Backend', which is __abstract by design__.
+--
+-- If you need to determine some property of the backend, do NOT match on
+-- 'DefunctionalizedCodeOutput'; Instead, write a new property predicate in
+-- this module. This makes it easier to add new backends because essentially
+-- all backend properties depended upon throughout the compiler are all found
+-- here.
+backendCodeOutput :: Backend -> Maybe DefunctionalizedCodeOutput
+backendCodeOutput (Named NCG) = Just NcgCodeOutput
+backendCodeOutput (Named LLVM) = Just LlvmCodeOutput
+backendCodeOutput (Named ViaC) = Just ViaCCodeOutput
+backendCodeOutput (Named JavaScript) = Just JSCodeOutput
+backendCodeOutput (Named Bytecode) = Nothing
+backendCodeOutput (Named NoBackend) = Nothing
backendUseJSLinker :: Backend -> Bool
backendUseJSLinker (Named NCG) = False
backendUseJSLinker (Named LLVM) = False
backendUseJSLinker (Named ViaC) = False
backendUseJSLinker (Named JavaScript) = True
-backendUseJSLinker (Named Bytecode) = False
+backendUseJSLinker (Named Bytecode) = False
backendUseJSLinker (Named NoBackend) = False
-- | This (defunctionalized) function tells the compiler
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -4,7 +4,6 @@
\section{Code output phase}
-}
-
module GHC.Driver.CodeOutput
( codeOutput
, outputForeignStubs
@@ -50,7 +49,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Logger
import GHC.Utils.Exception ( bracket )
import GHC.Utils.Ppr (Mode(..))
-import GHC.Utils.Panic.Plain ( pgmError )
+import GHC.Utils.Panic.Plain ( panic, pgmError )
import GHC.Unit
import GHC.Unit.Finder ( mkStubPaths )
@@ -124,11 +123,12 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g
; let dus1 = newTagDUniqSupply CodeGenTag dus0
; (stubs, a) <- case backendCodeOutput (backend dflags) of
- NcgCodeOutput -> outputAsm logger dflags this_mod location filenm dus1
- final_stream
- ViaCCodeOutput -> outputC logger dflags filenm dus1 final_stream pkg_deps
- LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm dus1 final_stream
- JSCodeOutput -> outputJS logger llvm_config dflags filenm final_stream
+ Just NcgCodeOutput -> outputAsm logger dflags this_mod location filenm dus1
+ final_stream
+ Just ViaCCodeOutput -> outputC logger dflags filenm dus1 final_stream pkg_deps
+ Just LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm dus1 final_stream
+ Just JSCodeOutput -> outputJS logger llvm_config dflags filenm final_stream
+ Nothing -> panic $ "backendCodeOutput: " ++ show (backend dflags) ++ " doesn't support code output"
; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs
; return (filenm, stubs_exist, foreign_fps, a)
}
=====================================
compiler/GHC/Driver/Main/Compile.hs
=====================================
@@ -670,7 +670,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do
-- next withTiming after this will be "Assembler" (hard code only).
withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ())
$ case backendCodeOutput (backend dflags) of
- JSCodeOutput ->
+ Just JSCodeOutput ->
do
let js_config = initStgToJSConfig dflags
@@ -696,7 +696,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do
stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs0 cost_centre_info output_filename
return (output_filename, stub_c_exists, foreign_fps, Just stg_cg_infos, Just cmm_cg_infos)
- _ ->
+ Just _ ->
do
cmms <- {-# SCC "StgToCmm" #-}
doCodeGen hsc_env this_mod denv tycons
@@ -724,6 +724,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do
foreign_stubs foreign_files dependencies (initDUniqSupply 'n' 0) rawcmms1
return ( output_filename, stub_c_exists, foreign_fps
, Just stg_cg_infos, Just cmm_cg_infos)
+ Nothing -> panic $ "backendCodeOutput: " ++ show (backend dflags) ++ " doesn't support code output"
-- The part of CgGuts that we need for HscInteractive
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -741,7 +741,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
let home_unit = hsc_home_unit hsc_env
case backendCodeOutput (backend dflags) of
- JSCodeOutput -> do
+ Just JSCodeOutput -> do
empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js"
let src = ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
writeFile empty_stub (showSDoc dflags (pprCode src))
@@ -750,7 +750,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
_ <- runPipeline (hsc_hooks hsc_env) pipeline
pure ()
- _ -> do
+ Just _ -> do
empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
let src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
writeFile empty_stub (showSDoc dflags (pprCode src))
@@ -758,6 +758,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub
_ <- runPipeline (hsc_hooks hsc_env) pipeline
pure ()
+ Nothing -> panic $ "backendCodeOutput: " ++ show (backend dflags) ++ " doesn't support code output"
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -276,7 +276,7 @@ import GHC.Data.FastString
import GHC.Utils.TmpFs
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
-import GHC.Utils.Error (emptyDiagOpts, logInfo)
+import GHC.Utils.Error (emptyDiagOpts, logInfo, Validity'(..))
import GHC.Settings
import GHC.CmmToAsm.CFG.Weight
import GHC.Core.Opt.CallerCC
@@ -3855,8 +3855,8 @@ makeDynFlagsConsistent dflags
&& os == OSMinGW32
&& arch == ArchAArch64
= case backendCodeOutput (backend dflags) of
- LlvmCodeOutput -> pgmError "-fllvm is incompatible with enabled TablesNextToCode at Windows Aarch64"
- NcgCodeOutput -> pgmError "-fasm is incompatible with enabled TablesNextToCode at Windows Aarch64"
+ Just LlvmCodeOutput -> pgmError "-fllvm is incompatible with enabled TablesNextToCode at Windows Aarch64"
+ Just NcgCodeOutput -> pgmError "-fasm is incompatible with enabled TablesNextToCode at Windows Aarch64"
_ -> (dflags, mempty, mempty)
-- When we do ghci, force using dyn ways if the target RTS linker
@@ -3902,9 +3902,8 @@ makeDynFlagsConsistent dflags
in dflags_c
| gopt Opt_InfoTableMap dflags
- , LlvmCodeOutput <- backendCodeOutput (backend dflags)
- = loop (gopt_unset dflags Opt_InfoTableMap)
- "-finfo-table-map is incompatible with -fllvm and is disabled (See #26435)"
+ , NotValid msg <- backendInfoTableMapValidity (backend dflags)
+ = loop (gopt_unset dflags Opt_InfoTableMap) msg
| otherwise = (dflags, mempty, mempty)
where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")
=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -385,6 +385,14 @@ test('ListTuplePunsPpr', normal, ghci_script, ['ListTuplePunsPpr.script'])
test('ListTuplePunsPprNoAbbrevTuple', [limit_stdout_lines(14)], ghci_script, ['ListTuplePunsPprNoAbbrevTuple.script'])
test('T24459', normal, ghci_script, ['T24459.script'])
test('T24632', normal, ghci_script, ['T24632.script'])
+# bytecode backend doesn't support '-finfo-table-map' (#27039)
+test('bytecodeIPE',
+ [ extra_hc_opts('-finfo-table-map')
+ , extra_files(['bytecodeIPE.hs'])
+ , req_rts_linker
+ , when(arch('wasm32') or arch('javascript'), skip)
+ ],
+ ghci_script, ['bytecodeIPE.script'])
# Test package renaming in GHCi session
test('GhciPackageRename',
=====================================
testsuite/tests/ghci/scripts/bytecodeIPE.hs
=====================================
@@ -0,0 +1,12 @@
+module BytecodeIPE where
+
+import Data.Maybe (isJust)
+import GHC.InfoProv (whereFrom)
+
+marker :: String
+marker = id "bytecode-stub-init"
+{-# NOINLINE marker #-}
+
+-- `whereFrom` only succeeds if the module's IPE initializer ran.
+probe :: IO Bool
+probe = isJust <$> whereFrom marker
=====================================
testsuite/tests/ghci/scripts/bytecodeIPE.script
=====================================
@@ -0,0 +1,2 @@
+:load bytecodeIPE.hs
+probe
=====================================
testsuite/tests/ghci/scripts/bytecodeIPE.stderr
=====================================
@@ -0,0 +1,2 @@
+when making flags consistent: warning: [GHC-74335] [-Winconsistent-flags (in -Wdefault)]
+ -finfo-table-map is incompatible with -fbyte-code interpreter and is disabled
=====================================
testsuite/tests/ghci/scripts/bytecodeIPE.stdout
=====================================
@@ -0,0 +1 @@
+False
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8f0fb507c2c0650f8a4df6caacac1d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8f0fb507c2c0650f8a4df6caacac1d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/davide/windows-dlls] WIP export-all-symbols from hadrian
by David Eichmann (＠DavidEichmann) 30 Jun '26
by David Eichmann (＠DavidEichmann) 30 Jun '26
30 Jun '26
David Eichmann pushed to branch wip/davide/windows-dlls at Glasgow Haskell Compiler / GHC
Commits:
1c68f726 by David Eichmann at 2026-06-30T16:37:36+01:00
WIP export-all-symbols from hadrian
- - - - -
20 changed files:
- compiler/GHC/CmmToAsm/Config.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/Driver/Config/CmmToAsm.hs
- libraries/Win32
- libraries/base/src/Control/Concurrent.hs
- libraries/bytestring
- libraries/file-io
- libraries/ghc-internal/cbits/RtsIface.c
- libraries/ghc-internal/cbits/Win32Utils.c
- libraries/ghc-internal/cbits/inputReady.c
- libraries/ghc-internal/include/HsBase.h
- libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/GMP.hs
- libraries/ghc-internal/src/GHC/Internal/Float.hs
- libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs
- libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Windows/Handle.hsc
- libraries/ghc-internal/src/GHC/Internal/System/IO.hs
- libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
- libraries/ghc-internal/src/GHC/Internal/Windows.hs
- libraries/text
Changes:
=====================================
compiler/GHC/CmmToAsm/Config.hs
=====================================
@@ -21,6 +21,7 @@ data NCGConfig = NCGConfig
, ncgThisModule :: !Module -- ^ The name of the module we are currently compiling
, ncgProcAlignment :: !(Maybe Int) -- ^ Mandatory proc alignment
, ncgExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries
+ , ncgDynLib :: !Bool -- ^ Generate code for a shared dynamic library
, ncgPIC :: !Bool -- ^ Enable Position-Independent Code
, ncgInlineThresholdMemcpy :: !Word -- ^ If inlining `memcpy` produces less than this threshold (in pseudo-instruction unit), do it
, ncgInlineThresholdMemset :: !Word -- ^ Ditto for `memset`
=====================================
compiler/GHC/CmmToAsm/X86/Ppr.hs
=====================================
@@ -305,6 +305,7 @@ pprExport config lbl isCmmData =
if platformOS platform == OSMinGW32
&& platformTablesNextToCode platform
&& externallyVisibleCLabel lbl
+ && (ncgExternalDynamicRefs config || ncgDynLib config)
then let
asData = isCmmData || isInfoTableLabel lbl
in
=====================================
compiler/GHC/Driver/Config/CmmToAsm.hs
=====================================
@@ -21,6 +21,7 @@ initNCGConfig dflags this_mod = NCGConfig
, ncgAsmContext = initSDocContext dflags PprCode
, ncgProcAlignment = cmmProcAlignment dflags
, ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
+ , ncgDynLib = ghcLink dflags == LinkDynLib || dynamicNow dflags
, ncgPIC = positionIndependent dflags
, ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags
, ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags
=====================================
libraries/Win32
=====================================
@@ -1 +1 @@
-Subproject commit 7d0772bb265a6c59eb14c441cf65c778895528df
+Subproject commit b3d4064052dd6cd42a59d896b193c5c645a43aa9
=====================================
libraries/base/src/Control/Concurrent.hs
=====================================
@@ -132,6 +132,12 @@ import Control.Concurrent.Chan
import Control.Concurrent.QSem
import Control.Concurrent.QSemN
+
+-- Needed for windows dynamic builds
+-- TODO we may need to disable inlining of ccalls by default
+{-# NOINLINE waitFd #-}
+
+
{- $conc_intro
The concurrency extension for Haskell is described in the paper
=====================================
libraries/bytestring
=====================================
@@ -1 +1 @@
-Subproject commit d984ad00644c0157bad04900434b9d36f23633c5
+Subproject commit 739ceeb77746a97fea82d8dce7165de658993b08
=====================================
libraries/file-io
=====================================
@@ -1 +1 @@
-Subproject commit 21303160b5dd91d6197bd1d20a8796ba2a819d4e
+Subproject commit ea36fd962360bef588366b04609c2adc2c82eec7
=====================================
libraries/ghc-internal/cbits/RtsIface.c
=====================================
@@ -8,6 +8,7 @@
#include "Rts.h"
+__attribute__((dllexport))
void init_ghc_hs_iface(void);
// Forward declarations
=====================================
libraries/ghc-internal/cbits/Win32Utils.c
=====================================
@@ -138,6 +138,7 @@ LPWSTR base_getErrorMessage(DWORD err)
return what;
}
+__attribute__((dllexport))
int get_unique_file_info_hwnd(HANDLE h, HsWord64 *dev, HsWord64 *ino)
{
BY_HANDLE_FILE_INFORMATION info;
@@ -167,6 +168,7 @@ BOOL file_exists(LPCTSTR path)
}
/* If true then caller needs to free tempFileName. */
+__attribute__((dllexport))
bool __createUUIDTempFileErrNo (wchar_t* pathName, wchar_t* prefix,
wchar_t* suffix, wchar_t** tempFileName)
{
=====================================
libraries/ghc-internal/cbits/inputReady.c
=====================================
@@ -150,6 +150,7 @@ compute_WaitForSingleObject_timeout(bool infinite, Time remaining)
* 1 => Input ready, 0 => not ready, -1 => error
* On error, sets `errno`.
*/
+__attribute__((dllexport))
int
fdReady(int fd, bool write, int64_t msecs, bool isSock)
{
=====================================
libraries/ghc-internal/include/HsBase.h
=====================================
@@ -133,8 +133,8 @@
#if defined(_WIN32)
/* in Win32Utils.c */
-extern void maperrno (void);
-extern int maperrno_func(DWORD dwErrorCode);
+__attribute__((dllexport)) extern void maperrno (void);
+__attribute__((dllexport)) extern int maperrno_func(DWORD dwErrorCode);
extern HsWord64 getMonotonicUSec(void);
#endif
=====================================
libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/GMP.hs
=====================================
@@ -622,8 +622,11 @@ foreign import ccall unsafe "integer_gmp_mpn_xor_n"
-> IO ()
-- mp_bitcnt_t mpn_popcount (const mp_limb_t *s1p, mp_size_t n)
+{-# NOINLINE c_mpn_popcount #-}
+c_mpn_popcount :: ByteArray# -> GmpSize# -> Word#
+c_mpn_popcount a b = _c_mpn_popcount a b
foreign import ccall unsafe "gmp.h __gmpn_popcount"
- c_mpn_popcount :: ByteArray# -> GmpSize# -> Word#
+ _c_mpn_popcount :: ByteArray# -> GmpSize# -> Word#
-- double integer_gmp_mpn_get_d (const mp_limb_t sp[], const mp_size_t sn)
foreign import ccall unsafe "integer_gmp_mpn_get_d"
=====================================
libraries/ghc-internal/src/GHC/Internal/Float.hs
=====================================
@@ -1632,17 +1632,47 @@ atanhDouble (D# x) = D# (atanhDouble# x)
powerDouble :: Double -> Double -> Double
powerDouble (D# x) (D# y) = D# (x **## y)
-foreign import ccall unsafe "isFloatNaN" isFloatNaN :: Float -> Int
-foreign import ccall unsafe "isFloatInfinite" isFloatInfinite :: Float -> Int
-foreign import ccall unsafe "isFloatDenormalized" isFloatDenormalized :: Float -> Int
-foreign import ccall unsafe "isFloatNegativeZero" isFloatNegativeZero :: Float -> Int
-foreign import ccall unsafe "isFloatFinite" isFloatFinite :: Float -> Int
-
-foreign import ccall unsafe "isDoubleNaN" isDoubleNaN :: Double -> Int
-foreign import ccall unsafe "isDoubleInfinite" isDoubleInfinite :: Double -> Int
-foreign import ccall unsafe "isDoubleDenormalized" isDoubleDenormalized :: Double -> Int
-foreign import ccall unsafe "isDoubleNegativeZero" isDoubleNegativeZero :: Double -> Int
-foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int
+{-# NOINLINE isFloatInfinite #-}
+isFloatInfinite :: Float -> Int
+isFloatInfinite x = cIsFloatInfinite x
+foreign import ccall unsafe "isFloatInfinite" cIsFloatInfinite :: Float -> Int
+{-# NOINLINE isFloatNaN #-}
+isFloatNaN :: Float -> Int
+isFloatNaN = _isFloatNaN
+foreign import ccall unsafe "isFloatNaN" _isFloatNaN :: Float -> Int
+{-# NOINLINE isFloatDenormalized #-}
+isFloatDenormalized :: Float -> Int
+isFloatDenormalized = _isFloatDenormalized
+foreign import ccall unsafe "isFloatDenormalized" _isFloatDenormalized :: Float -> Int
+{-# NOINLINE isFloatNegativeZero #-}
+isFloatNegativeZero :: Float -> Int
+isFloatNegativeZero = _isFloatNegativeZero
+foreign import ccall unsafe "isFloatNegativeZero" _isFloatNegativeZero :: Float -> Int
+{-# NOINLINE isFloatFinite #-}
+isFloatFinite :: Float -> Int
+isFloatFinite = _isFloatFinite
+foreign import ccall unsafe "isFloatFinite" _isFloatFinite :: Float -> Int
+
+{-# NOINLINE isDoubleInfinite #-}
+isDoubleInfinite :: Double -> Int
+isDoubleInfinite x = cIsDoubleInfinite x
+foreign import ccall unsafe "isDoubleInfinite" cIsDoubleInfinite :: Double -> Int
+{-# NOINLINE isDoubleNaN #-}
+isDoubleNaN :: Double -> Int
+isDoubleNaN = _isDoubleNaN
+foreign import ccall unsafe "isDoubleNaN" _isDoubleNaN :: Double -> Int
+{-# NOINLINE isDoubleDenormalized #-}
+isDoubleDenormalized :: Double -> Int
+isDoubleDenormalized = _isDoubleDenormalized
+foreign import ccall unsafe "isDoubleDenormalized" _isDoubleDenormalized :: Double -> Int
+{-# NOINLINE isDoubleNegativeZero #-}
+isDoubleNegativeZero :: Double -> Int
+isDoubleNegativeZero = _isDoubleNegativeZero
+foreign import ccall unsafe "isDoubleNegativeZero" _isDoubleNegativeZero :: Double -> Int
+{-# NOINLINE isDoubleFinite #-}
+isDoubleFinite :: Double -> Int
+isDoubleFinite = _isDoubleFinite
+foreign import ccall unsafe "isDoubleFinite" _isDoubleFinite :: Double -> Int
------------------------------------------------------------------------
-- Coercion rules
=====================================
libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs
=====================================
@@ -357,5 +357,8 @@ float2Integer (F# x) =
foreign import ccall unsafe "rintDouble"
c_rintDouble :: Double -> Double
+{-# NOINLINE c_rintFloat #-}
+c_rintFloat :: Float -> Float
+c_rintFloat = _c_rintFloat
foreign import ccall unsafe "rintFloat"
- c_rintFloat :: Float -> Float
+ _c_rintFloat :: Float -> Float
=====================================
libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs
=====================================
@@ -109,6 +109,14 @@ import GHC.Internal.Num
import GHC.Internal.Base ( String, otherwise, return, ($) )
import GHC.Internal.Types ( Bool(..) )
+
+
+-- Needed for windows dynamic builds
+-- TODO we may need to disable inlining of ccalls by default
+{-# NOINLINE getErrno #-}
+
+
+
-- "errno" type
-- ------------
=====================================
libraries/ghc-internal/src/GHC/Internal/IO/Windows/Handle.hsc
=====================================
@@ -384,11 +384,17 @@ foreign import ccall safe "__set_console_echo"
foreign import ccall safe "__get_console_echo"
c_get_console_echo :: HANDLE -> IO BOOL
+{-# NOINLINE c_close_handle #-}
+c_close_handle :: HANDLE -> IO Bool
+c_close_handle = _c_close_handle
foreign import ccall safe "__close_handle"
- c_close_handle :: HANDLE -> IO Bool
+ _c_close_handle :: HANDLE -> IO Bool
+{-# NOINLINE c_handle_type #-}
+c_handle_type :: HANDLE -> IO Int
+c_handle_type = _c_handle_type
foreign import ccall safe "__handle_type"
- c_handle_type :: HANDLE -> IO Int
+ _c_handle_type :: HANDLE -> IO Int
foreign import ccall safe "__set_file_pointer"
c_set_file_pointer :: HANDLE -> CLong -> DWORD -> Ptr CLong -> IO BOOL
@@ -990,8 +996,11 @@ handleToMode hwnd = do
| hasFlag (#{const GENERIC_WRITE}) -> return WriteMode
| otherwise -> error "unknown access mask in handleToMode."
+{-# NOINLINE c_get_handle_access_mask #-}
+c_get_handle_access_mask :: HANDLE -> IO DWORD
+c_get_handle_access_mask = _c_get_handle_access_mask
foreign import ccall unsafe "__get_handle_access_mask"
- c_get_handle_access_mask :: HANDLE -> IO DWORD
+ _c_get_handle_access_mask :: HANDLE -> IO DWORD
release :: RawHandle a => a -> IO ()
release h = if isLockable h
@@ -1011,11 +1020,15 @@ foreign import ccall unsafe "unlockFile"
-- | Returns -1 on error. Otherwise writes two values representing
-- the file into the given ptrs.
+{-# NOINLINE c_getUniqueFileInfo #-}
+c_getUniqueFileInfo :: HANDLE -> Ptr Word64 -> Ptr Word64 -> IO ()
+c_getUniqueFileInfo = _c_getUniqueFileInfo
foreign import ccall unsafe "get_unique_file_info_hwnd"
- c_getUniqueFileInfo :: HANDLE -> Ptr Word64 -> Ptr Word64 -> IO ()
+ _c_getUniqueFileInfo :: HANDLE -> Ptr Word64 -> Ptr Word64 -> IO ()
-- | getUniqueFileInfo assumes the C call to getUniqueFileInfo
-- succeeds.
+{-# NOINLINE getUniqueFileInfo #-}
getUniqueFileInfo :: RawHandle a => a -> IO (Word64, Word64)
getUniqueFileInfo handle = do
with 0 $ \devptr -> do
=====================================
libraries/ghc-internal/src/GHC/Internal/System/IO.hs
=====================================
@@ -738,7 +738,10 @@ openTempFile' loc tmp_dir template binary mode
foreign import ccall "getTempFileNameErrorNo" c_getTempFileNameErrorNo
:: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool
-foreign import ccall "__createUUIDTempFileErrNo" c_createUUIDTempFileErrNo
+{-# NOINLINE c_createUUIDTempFileErrNo #-}
+c_createUUIDTempFileErrNo :: CWString -> CWString -> CWString -> Ptr CWString -> IO Bool
+c_createUUIDTempFileErrNo = _c_createUUIDTempFileErrNo
+foreign import ccall "__createUUIDTempFileErrNo" _c_createUUIDTempFileErrNo
:: CWString -> CWString -> CWString -> Ptr CWString -> IO Bool
pathSeparator :: String -> Bool
=====================================
libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
=====================================
@@ -747,8 +747,12 @@ foreign import capi unsafe "HsBase.h _unlink"
foreign import capi unsafe "HsBase.h _utime"
c_utime :: CString -> Ptr CUtimbuf -> IO CInt
+
+{-# NOINLINE c_getpid #-}
+c_getpid :: IO CPid
+c_getpid = _c_getpid
foreign import capi unsafe "HsBase.h _getpid"
- c_getpid :: IO CPid
+ _c_getpid :: IO CPid
#else
-- We use CAPI as on some OSs (eg. Linux) this is wrapped by a macro
-- which redirects to the 64-bit-off_t versions when large file
@@ -833,8 +837,11 @@ foreign import capi unsafe "HsBase.h utime"
c_getpid :: IO CPid
c_getpid = pure 1
#else
+{-# NOINLINE c_getpid #-}
+c_getpid :: IO CPid
+c_getpid = _c_getpid
foreign import ccall unsafe "HsBase.h getpid"
- c_getpid :: IO CPid
+ _c_getpid :: IO CPid
#endif
#endif
@@ -924,7 +931,10 @@ foreign import ccall unsafe "HsBase.h __hscore_o_wronly" o_WRONLY :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_rdwr" o_RDWR :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_append" o_APPEND :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_creat" o_CREAT :: CInt
-foreign import ccall unsafe "HsBase.h __hscore_o_excl" o_EXCL :: CInt
+{-# NOINLINE o_EXCL #-}
+o_EXCL :: CInt
+o_EXCL = _o_EXCL
+foreign import ccall unsafe "HsBase.h __hscore_o_excl" _o_EXCL :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_trunc" o_TRUNC :: CInt
-- non-POSIX flags.
=====================================
libraries/ghc-internal/src/GHC/Internal/Windows.hs
=====================================
@@ -212,13 +212,19 @@ failUnlessSuccessOr val fn_name act = do
-- by @GetLastError@.
-- | Map the last system error to an errno value, and assign it to @errno@.
+{-# NOINLINE c_maperrno #-}
+c_maperrno :: IO ()
+c_maperrno = _c_maperrno
foreign import ccall unsafe "maperrno" -- in Win32Utils.c
- c_maperrno :: IO ()
+ _c_maperrno :: IO ()
-- | Pure function variant of 'c_maperrno' that does not call @GetLastError@
-- or modify @errno@.
+{-# NOINLINE c_maperrno_func #-}
+c_maperrno_func :: ErrCode -> Errno
+c_maperrno_func = _c_maperrno_func
foreign import ccall unsafe "maperrno_func" -- in Win32Utils.c
- c_maperrno_func :: ErrCode -> Errno
+ _c_maperrno_func :: ErrCode -> Errno
foreign import ccall unsafe "base_getErrorMessage" -- in Win32Utils.c
c_getErrorMessage :: DWORD -> IO LPWSTR
=====================================
libraries/text
=====================================
@@ -1 +1 @@
-Subproject commit 423fd981e576bd17a8b5fa48d0ad6b9a0c370e77
+Subproject commit a1e9d389911eb613f2951364b9203be92ebc3cfa
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c68f726b08ede1e81c0ae54d0e06ac…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c68f726b08ede1e81c0ae54d0e06ac…
You're receiving this email because of your account on gitlab.haskell.org.
1
0