September 2026 - ghc-commits

[Git][ghc/ghc][wip/clc-proposal-442] Add entry to changelog.d
by BinderDavid (＠BinderDavid) 23 Sep '26

23 Sep '26

BinderDavid pushed to branch wip/clc-proposal-442 at Glasgow Haskell Compiler / GHC Commits: e155f257 by David Binder at 2026-09-23T16:47:20+01:00 Add entry to changelog.d - - - - - 1 changed file: - + changelog.d/clc-442 Changes: ===================================== changelog.d/clc-442 ===================================== @@ -0,0 +1,9 @@ +section: base +issues: #27849 +mrs: !16718 +synopsis: + Expose `data Unit` and `data TupleN` from `Data.Tuple` in `base` +description: + The data types `data Unit` and `data TupleN` (for N from 2 to 64) are now exported from + `Data.Tuple` in the `base` library instead of `Data.Tuple.Experimental` in `ghc-experimental`. + See `CLC proposal 442 <https://github.com/haskell/core-libraries-committee/issues/442>`_. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e155f2576ea957c3ee5ef4478b802d7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e155f2576ea957c3ee5ef4478b802d7… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/multi-threaded-debugger] 4 commits: Build EvalOpts once per exec rather than per breakpoint stop
by Rodrigo Mesquita (＠alt-romes) 23 Sep '26

23 Sep '26

Rodrigo Mesquita pushed to branch wip/romes/multi-threaded-debugger at Glasgow Haskell Compiler / GHC Commits: aab472ba by Rodrigo Mesquita at 2026-09-22T11:54:27+01:00 Build EvalOpts once per exec rather than per breakpoint stop in interpreter_steplocal the allocations increased because now we're updating `eval_opts` after constructing them in `handleRunStatus` (which is run many times since in step-local most often we don't stop, just check). So drop the update to the eval_opts, and, in fact, pull their construction out. the loop always uses the same eval_opts, so no point in constructing them inside from scratch every time. -3.6% from this branch which had the regressions in interpreter_steplocal - - - - - a3ebc544 by Rodrigo Mesquita at 2026-09-22T16:20:35+01:00 Look up a thread's ResumeContext without taking a lock modifyMVar is unnecessarily expensive and blocking when most often we just care about reading without modifying. optimize for default case (thread context already exists). It is called every single time a breakpoint is hit (regardless of whether we stop there, e.g. in interpreter_steplocal we do not stop there often) - - - - - cd553e96 by Rodrigo Mesquita at 2026-09-22T18:15:21+01:00 Every thread resume-context keeps a var for its EvalStatus Kill the global mapping from thread id to EvalStatus Instead, keep the EvalStatus in the ResumeContext associated to a thread in the threadContextVar (where entries are created on breakpoints being hit and when writing an EvalComplete result) Before, every breakpoint hit meant reading the global map TVar and deleting a map entry which did a lot of allocations. Now, we have a Nothing variable which we overwrite to "take" rather than deleting from a Map and allocating the GlobalDbgMap too. Note that for every breakpoint hit we'd have to insert the ThreadId entry in the map again (because we deleted it last time we resumed), again allocating unnecessarily. Now it's only a look up on the map and an update on the variable directly. And a LOT of breakpoints were hit on interpreter_steplocal, stress testing the cost of hitting a breakpoint The isolated threads move to their own top-level TVar Set. - - - - - 64836f8c by Rodrigo Mesquita at 2026-09-23T16:18:18+01:00 Move whether a thread is isolated to the same global map Stops us from reconstructing the set every time this changed instead to being a per thread variable just toggled on/off, by default non-isolated like before (before it was Set.empty, Set.insert for True, Set.delete for FALSE). This is more straightforward -- there's always an isolation mode per thread and we can toggle it directly - - - - - 5 changed files: - compiler/GHC/Driver/Config.hs - compiler/GHC/Runtime/Eval.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/GHCi/Run/Breakpoints.hs Changes: ===================================== compiler/GHC/Driver/Config.hs ===================================== @@ -41,15 +41,15 @@ data EvalStep | EvalStepNone -- | Extract GHCi options from DynFlags and step -initEvalOpts :: DynFlags -> EvalStep -> EvalOpts -initEvalOpts dflags step = +initEvalOpts :: DynFlags -> EvalStep -> Bool -> EvalOpts +initEvalOpts dflags step isolate_breaks = EvalOpts { useSandboxThread = gopt Opt_GhciSandbox dflags , singleStep = singleStep , stepOut = stepOut , breakOnException = gopt Opt_BreakOnException dflags , breakOnError = gopt Opt_BreakOnError dflags - , isolateThreadBreaks = True + , isolateThreadBreaks = isolate_breaks -- Must opt-in to listening to all thread's breakpoints. -- (e.g. for running 'main' in a debugger) } ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -230,18 +230,16 @@ execStmt' stmt stmt_text ExecOptions{..} = do Just (ids, hval, fix_env) -> do updateFixityEnv fix_env - status <- - liftIO $ do - let eval_opts = (initEvalOpts idflags' (enableGhcStepMode execSingleStep)) - { isolateThreadBreaks = enableIsolateThreadBreaks execIsolateMode } - evalStmt interp eval_opts (execWrap hval) + let eval_opts = initEvalOpts idflags' (enableGhcStepMode execSingleStep) + (enableIsolateThreadBreaks execIsolateMode) + status <- liftIO $ evalStmt interp eval_opts (execWrap hval) let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_gre_cache ic) size = ghciHistSize idflags' - handleRunStatus execSingleStep execIsolateMode stmt_text bindings ids + handleRunStatus execSingleStep eval_opts stmt_text bindings ids status (emptyHistory size) runDecls :: GhcMonad m => String -> m [TyThing] @@ -293,18 +291,22 @@ emptyHistory size = nilBL size -- or :stepmodule, rather than :step, we only care about certain breakpoints). handleRunStatus :: GhcMonad m => SingleStep - -> ThreadBreaksIsolationMode + -- ^ The kind of step we're doing. 'handleRunStatus' may resume + -- the evaluation automatically if the step kind indicates to + -- ignore this breakpoint (e.g. when doing 'ModuleStep' but the + -- breakpoint just hit belongs to a different module) + -> EvalOpts + -- ^ The evaluation options in case the evaluation is resumed. -> String -> ResumeBindings -> [Id] -> EvalStatus_ [ForeignHValue] [HValueRef] -> BoundedList History -> m ExecResult -handleRunStatus step isolateMode expr bindings final_ids status history0 = do +handleRunStatus step eval_opts expr bindings final_ids status history0 = do hsc_env <- getSession let interp = hscInterp hsc_env - dflags = hsc_dflags hsc_env case status of -- Completed successfully @@ -396,15 +398,13 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do return (ExecBreak break_ids (Just ibi) resume) else do -- resume with the same step type - let eval_opts = (initEvalOpts dflags (enableGhcStepMode step)) - { isolateThreadBreaks = enableIsolateThreadBreaks isolateMode } status <- liftIO $ GHCi.resumeStmt interp eval_opts resume_ctxt_fhv history <- if not tracing then pure history0 else do history1 <- liftIO $ mkHistory hug apStack_fhv ibi let !history' = history1 `consBL` history0 -- history is strict, otherwise our BoundedList is pointless. return history' - handleRunStatus step isolateMode expr bindings final_ids status history + handleRunStatus step eval_opts expr bindings final_ids status history where tracing | RunAndLogSteps <- step = True | otherwise = False @@ -452,8 +452,8 @@ resumeExec step isolateMode mbCnt r = do (Just brkpt, Just cnt) -> setupBreakpoint interp brkpt cnt _ -> return () - let eval_opts = (initEvalOpts dflags (enableGhcStepMode step)) - { isolateThreadBreaks = enableIsolateThreadBreaks isolateMode } + let eval_opts = initEvalOpts dflags (enableGhcStepMode step) + (enableIsolateThreadBreaks isolateMode) status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv let prevHistoryLst = fromListBL 50 hist hug = hsc_HUG hsc_env @@ -464,7 +464,7 @@ resumeExec step isolateMode mbCnt r = do hist1 <- liftIO (mkHistory hug apStack bi) return $ hist1 `consBL` fromListBL 50 hist | otherwise -> pure prevHistoryLst - handleRunStatus step isolateMode expr bindings final_ids status =<< hist' + handleRunStatus step eval_opts expr bindings final_ids status =<< hist' setupBreakpoint :: GhcMonad m => Interp -> InternalBreakpointId -> Int -> m () -- #19157 setupBreakpoint interp ibi cnt = do @@ -1274,7 +1274,7 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do _ -> panic "compileParsedExprRemote" updateFixityEnv fix_env - let eval_opts = initEvalOpts dflags EvalStepNone + let eval_opts = initEvalOpts dflags EvalStepNone True status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io) case status of EvalComplete _ (EvalSuccess [hval]) -> return hval ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -395,7 +395,7 @@ data EvalOpts , stepOut :: Bool , breakOnException :: Bool , breakOnError :: Bool - , isolateThreadBreaks :: Bool + , isolateThreadBreaks :: !Bool -- ^ If @isolateThreadBreaks == True@, any breakpoint hit by the thread -- forked~[1] to execute this expression is only seen by a caller observing -- this thread's result explicitly. That is, this thread's 'EvalStatus' can ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -405,10 +405,11 @@ sandboxIO opts io -- rather than just "main" being observed. This should be used for the main -- debuggee execution of a debugger. withBreakAction :: EvalOpts -> ThreadId -> (IO (EvalStatus [HValueRef]) -> IO a) -> IO a -withBreakAction opts tid@(ThreadId tid#) act - = bracket setBreakAction resetBreakAction (\_ -> act waitForResult) +withBreakAction opts tid@(ThreadId tid#) act = do + ctx <- getThreadResumeContext tid + bracket (setBreakAction ctx) (resetBreakAction ctx) (\_ -> act (waitForResult ctx)) where - setBreakAction = do + setBreakAction ctx = do poke breakPointIOAction globalBreakStablePtr -- TODO: This is poke thread unsafe, as one thread might be accessing this -- global variable while this thread tries to overwrite it. We should @@ -422,32 +423,34 @@ withBreakAction opts tid@(ThreadId tid#) act runIf# singleStep rts_enableStopNextBreakpoint runIf# stepOut rts_enableStopAfterReturn - runIf isolateThreadBreaks setIsolatedThread - resetBreakAction () = do + runIfCtx ctx isolateThreadBreaks setIsolatedCtx + + resetBreakAction ctx () = do poke exceptionFlag 0 rts_disableStopAfterReturn tid# rts_disableStopNextBreakpoint tid# - runIf isolateThreadBreaks unsetIsolatedThread + runIfCtx ctx isolateThreadBreaks unsetIsolatedCtx -- freeStablePtr stablePtr TODO: we never free the global stablePtr for -- global action. Maybe we should have a de-init for clean up. -- TODO: don't set it in `setBreakAction` either. Should be on -- interpreter initialization. - runIf pred what = when (pred opts) (what tid) - runIf# pred what = when (pred opts) (what tid#) + runIf pred what = when (pred opts) (what tid) + runIf# pred what = when (pred opts) (what tid#) + runIfCtx ctx pred what = when (pred opts) (what ctx) - waitForResult + waitForResult ctx | isolateThreadBreaks opts = atomically $ - readThreadEvalStatus tid + readCtxEvalStatus ctx | otherwise = atomically $ (EvalPaused <$> readAnyThreadEvalBreak) `orElse` - readThreadEvalStatus tid + readCtxEvalStatus ctx -- While we're waiting for the sandbox thread to return a result, if -- the current thread receives an asynchronous exception we re-throw ===================================== libraries/ghci/GHCi/Run/Breakpoints.hs ===================================== @@ -8,10 +8,12 @@ module GHCi.Run.Breakpoints -- * Per-thread breakpoints , readThreadEvalStatus, readAnyThreadEvalBreak , writeThreadEvalStatus + , readCtxEvalStatus, writeCtxEvalStatus -- ** Isolating thread breakpoints , withIsolatedThread , setIsolatedThread, unsetIsolatedThread + , setIsolatedCtx, unsetIsolatedCtx -- ** Querying the global thread breakpoint map , listOtherPausedThreads @@ -29,18 +31,15 @@ import GHCi.Message import GHCi.RemoteTypes import qualified Data.Map as Map -import qualified Data.Set as Set import Control.Concurrent import Control.Exception import qualified Data.ByteString.Short.Internal as BS -#if defined(PROFILING) -import GHC.Data.ShortByteString -#endif import GHC.Exts import GHC.Stack import Foreign hiding (void) import GHC.Conc.Sync import GHC.IO hiding ( bracket ) +import Control.Monad -------------------------------------------------------------------------------- -- * Global break action @@ -72,7 +71,7 @@ globalBreakStablePtr = unsafePerformIO $ newStablePtr globalBreakAction globalBreakAction :: BreakpointCallback globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do tid <- myThreadId - ResumeContext{..} <- getThreadResumeContext tid + ctx@ResumeContext{..} <- getThreadResumeContext tid resume_r <- mkRemoteRef tid apStack_r <- mkRemoteRef apStack ccs <- toRemotePtr <$> getCCSOf apStack @@ -83,7 +82,7 @@ globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do info_mod <- BS.packCString (Ptr info_mod#) info_mod_uid <- BS.packCString (Ptr info_mod_uid#) pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#))) - writeThreadEvalStatus tid $ EvalBreak apStack_r mb_breakpoint resume_r ccs + writeCtxEvalStatus ctx $ EvalBreak apStack_r mb_breakpoint resume_r ccs -- Block until this thread is resumed (by the thread which took the -- `ResumeContext` from the `statusMVar`). @@ -109,14 +108,19 @@ globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do -- Succeeds when the given thread writes to the global debugger map an eval result. readThreadEvalStatus :: ThreadId -> STM (EvalStatus [HValueRef]) readThreadEvalStatus tid = do - GlobalDbgStatus{..} <- readTVar globalDbgStatusVar - case Map.lookup tid threadEvalStatuses of + ctxs <- readTVar threadContextsVar + case Map.lookup tid ctxs of + Just ctx -> readCtxEvalStatus ctx + Nothing -> retry -- to write a thread break or result, the + -- 'threadContextsVar' entry will be created + +-- | Like 'readThreadEvalStatus', but when the 'ResumeContext' is already +-- available (to avoid looking it up unnecessarily). +readCtxEvalStatus :: ResumeContext -> STM (EvalStatus [HValueRef]) +readCtxEvalStatus ResumeContext{resumeEvalStatus} = + readTVar resumeEvalStatus >>= \case Just r -> do - writeTVar globalDbgStatusVar - GlobalDbgStatus - { threadEvalStatuses = Map.delete tid threadEvalStatuses -- clear it - , isolatedThreads - } + writeTVar resumeEvalStatus Nothing -- clear it pure r Nothing -> retry -- until someone writes the result for this thread @@ -128,36 +132,38 @@ readThreadEvalStatus tid = do -- Succeeds when any thread hits a breakpoint. readAnyThreadEvalBreak :: STM EvalBreak readAnyThreadEvalBreak = do - dbgs <- readTVar globalDbgStatusVar + ctxs <- readTVar threadContextsVar -- try reading any thread's 'EvalBreak' and retry if none have yielded one yet - foldr (\x next -> readStatus dbgs x `orElse` next) retry (Map.toList (threadEvalStatuses dbgs)) + foldr (\ctx next -> readBreak ctx `orElse` next) retry (Map.elems ctxs) where - readStatus GlobalDbgStatus{..} (tid, _) -- don't look at isolated threads - | Set.member tid isolatedThreads - = retry - - readStatus GlobalDbgStatus{..} (tid, status) - = do - case status of - EvalComplete{} -> retry -- successes can be read with `readThreadEvalStatus` - EvalPaused b -> do - writeTVar globalDbgStatusVar - GlobalDbgStatus - { threadEvalStatuses = Map.delete tid threadEvalStatuses - , isolatedThreads - } - pure b + readBreak ResumeContext{resumeEvalStatus, resumeIsolated} = do + isolated <- readTVar resumeIsolated + if isolated + then retry -- don't look at isolated threads + else readTVar resumeEvalStatus >>= \case + Just (EvalPaused b) -> do + writeTVar resumeEvalStatus Nothing + pure b + Just EvalComplete{} -> + retry -- successes can be read with `readThreadEvalStatus` + Nothing -> + retry -- no status for this thread yet writeThreadEvalStatus :: ThreadId -> EvalStatus [HValueRef] -> IO () -writeThreadEvalStatus tid status = +writeThreadEvalStatus tid status = do + -- get or create a 'ResumeContext' for the thread (e.g. we may write the + -- EvalComplete without breakpoints occurring, so the map won't have an entry): + ctx <- getThreadResumeContext tid + writeCtxEvalStatus ctx status + +-- | Like 'writeThreadEvalStatus', but for when the 'ResumeContext' is already +-- available +writeCtxEvalStatus :: ResumeContext -> EvalStatus [HValueRef] -> IO () +writeCtxEvalStatus ResumeContext{resumeEvalStatus} status = atomically $ do - GlobalDbgStatus{..} <- readTVar globalDbgStatusVar - writeTVar globalDbgStatusVar $ - GlobalDbgStatus - { threadEvalStatuses = - Map.insertWith (\_ _ -> error "writeThreadEvalStatus: should be impossible") - tid status threadEvalStatuses - , isolatedThreads } + readTVar resumeEvalStatus >>= \case + Just{} -> error "writeCtxEvalStatus: should be impossible" + Nothing -> writeTVar resumeEvalStatus (Just status) -- ** Isolating thread breakpoints --------------------------------------------- @@ -174,23 +180,15 @@ withIsolatedThread tid = bracket_ (setIsolatedThread tid) (unsetIsolatedThread t -- expression to run should not be seen at all by the debugger (e.g. when -- evaluating an expr to :force a variable) setIsolatedThread :: ThreadId -> IO () -setIsolatedThread tid = atomically $ do - GlobalDbgStatus{..} <- readTVar globalDbgStatusVar - writeTVar globalDbgStatusVar - GlobalDbgStatus - { threadEvalStatuses - , isolatedThreads = Set.insert tid isolatedThreads - } +setIsolatedThread = getThreadResumeContext >=> setIsolatedCtx -- | Undoes 'setIsolatedThread' unsetIsolatedThread :: ThreadId -> IO () -unsetIsolatedThread tid = atomically $ do - GlobalDbgStatus{..} <- readTVar globalDbgStatusVar - writeTVar globalDbgStatusVar - GlobalDbgStatus - { threadEvalStatuses - , isolatedThreads = Set.delete tid isolatedThreads - } +unsetIsolatedThread = getThreadResumeContext >=> unsetIsolatedCtx + +setIsolatedCtx, unsetIsolatedCtx :: ResumeContext -> IO () +setIsolatedCtx ctx = atomically $ writeTVar (resumeIsolated ctx) True +unsetIsolatedCtx ctx = atomically $ writeTVar (resumeIsolated ctx) False -- ** Querying the global thread breakpoint map -------------------------------- @@ -201,64 +199,74 @@ unsetIsolatedThread tid = atomically $ do -- the global thread mapping) and are asking about which other threads are -- paused to list them. listOtherPausedThreads :: IO [ThreadId] -listOtherPausedThreads = do - m <- atomically $ readTVar globalDbgStatusVar - pure $ Map.keys $ Map.filter isBreak (threadEvalStatuses m) +listOtherPausedThreads = atomically $ do + ctxs <- readTVar threadContextsVar + paused <- mapM isBreak (Map.toList ctxs) + pure [tid | (tid, True) <- paused] where - isBreak EvalBreak{} = True - isBreak EvalComplete{} = False - --- ** Global thread exec status map -------------------------------------------- - --- | When we launch a new thread using the debugger, we map ... TODO ... all --- threads launched by that main stmt may further spawn threads, and any of --- them might hit a breakpoint (break array toggled, or per-thread step in --- might be used, or pause button, etc...). --- --- When we launch that main thread we also write its result to this map. So --- this map will only contain the results of threads we explicitly care to --- observe the result of. Not all threads will write their results here, --- certainly not ones spawned unknowningly by the main stmt. --- ... --- todo words -globalDbgStatusVar :: TVar GlobalDbgStatus -globalDbgStatusVar = unsafePerformIO $ newTVarIO $ GlobalDbgStatus Map.empty Set.empty -{-# NOINLINE globalDbgStatusVar #-} - -data GlobalDbgStatus = GlobalDbgStatus - { threadEvalStatuses :: !(Map.Map ThreadId (EvalStatus [HValueRef])) - -- ^ Whenever a thread hits a breakpoint it inserts in this map its 'EvalBreak'. - -- We can additionally observe a thread's result by calling - -- `writeThreadEvalStatus tid (EvalComplete ...)` when the main expression - -- finishes evaluating, see e.g. 'sandboxIO'. - , isolatedThreads :: !(Set.Set ThreadId) - -- ^ Threads in this map are meant to be ignored by 'readAnyThreadEvalBreak'. - -- That is, even if one of the threads in this set hits a breakpoint, we - -- can only read its 'EvalBreak' with @'readThreadEvalStatus' tid@ directly. - } + isBreak (tid, ResumeContext{resumeEvalStatus}) = do + status <- readTVar resumeEvalStatus + pure (tid, case status of + Just EvalBreak{} -> True + Just EvalComplete{} -> False + Nothing -> False) -------------------------------------------------------------------------------- -- * Per-thread resume-ing -------------------------------------------------------------------------------- getThreadResumeContext :: ThreadId -> IO ResumeContext -getThreadResumeContext tid = modifyMVar globalBreakActionMap $ \gbm0 -> do - case Map.lookup tid gbm0 of +getThreadResumeContext tid = do + ctxs0 <- readTVarIO threadContextsVar + case Map.lookup tid ctxs0 of + Just ctx -> pure ctx -- common case: hence read without transaction Nothing -> do - r <- ResumeContext <$> newEmptyMVar - let !gbm1 = Map.insert tid r gbm0 - pure (gbm1, r) - Just ctx -> do - pure (gbm0, ctx) + new_ctx <- ResumeContext <$> newEmptyMVar + <*> newTVarIO Nothing + <*> newTVarIO False + atomically $ do -- write new thread context atomically + ctxs1 <- readTVar threadContextsVar + case Map.lookup tid ctxs1 of + Just ctx -> pure ctx -- already exists + Nothing -> do + let !ctxs2 = Map.insert tid new_ctx ctxs1 + writeTVar threadContextsVar ctxs2 + pure new_ctx --- | A global mapping from thread ids to the MVars on which they block when stopped. -globalBreakActionMap :: MVar (Map.Map ThreadId ResumeContext) -globalBreakActionMap = unsafePerformIO $ newMVar Map.empty -{-# NOINLINE globalBreakActionMap #-} +-- | A global mapping from threads to their per-thread state 'ResumeContext' +-- (that e.g. contain the MVars on which they block when stopped) +threadContextsVar :: TVar (Map.Map ThreadId ResumeContext) +threadContextsVar = unsafePerformIO $ newTVarIO Map.empty +{-# NOINLINE threadContextsVar #-} -newtype ResumeContext = ResumeContext - { resumeBreakMVar :: MVar () +-- | Global context for a thread, which is created and inserted in the global +-- 'threadContextsVar' when a thread hits a breakpoint (and, thus, the +-- 'globalBreakAction') is run, or when 'withBreakAction' sets the thread +-- isolation (e.g. in 'sandboxIO'), or in other calls to +-- 'getThreadResumeContext', the function which gets or creates a thread +-- 'ResumeContext'. +-- +-- TODO: Rename ResumeContext to something like ThreadContext or +-- ThreadDbgContext or (Thread)BreakContext, and fields to something like +-- dbgEvalStatus, threadIsolated, ... +data ResumeContext = ResumeContext + { resumeBreakMVar :: !(MVar ()) -- ^ A thread that hits a breakpoint blocks reading its corresponding MVar - -- (gotten from the 'globalBreakActionMap'). + -- (gotten from the 'threadContextsVar'). -- The debugger can unblock that thread by signaling its MVar. + , resumeEvalStatus :: !(TVar (Maybe (EvalStatus [HValueRef]))) + -- ^ When a thread hits a breakpoint, the 'globalBreakAction' is run and + -- writes an 'EvalBreak' in this @TVar@ (which was found in 'threadContextsVar'). + -- + -- Additionally, the 'EvalComplete' result of a thread may be written here + -- using `writeThreadEvalStatus tid (EvalComplete ...)` after the main + -- expression finishes evaluating, see e.g. 'sandboxIO'. + -- + -- The variable should be emptied (i.e. set to 'Nothing') by whoever + -- reads the status. + , resumeIsolated :: !(TVar Bool) + -- ^ When set, this thread is meant to be ignored by 'readAnyThreadEvalBreak'. + -- That is, if a thread with resumeIsolated=True hits a breakpoint, its + -- 'EvalBreak' can only be read with @'readThreadEvalStatus' tid@ for this + -- thread's @tid@ directly. } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c0876759757f2ef4c2e8d7ea2de65e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c0876759757f2ef4c2e8d7ea2de65e… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/T27737] Deal with runRW# too
by Simon Peyton Jones (＠simonpj) 23 Sep '26

23 Sep '26

Simon Peyton Jones pushed to branch wip/T27737 at Glasgow Haskell Compiler / GHC Commits: 19218238 by Simon Peyton Jones at 2026-09-23T15:52:19+01:00 Deal with runRW# too ToDo: document this - - - - - 2 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1283,9 +1283,8 @@ simplExprF1 env expr@(Lam {}) cont -- and likewise drop counts all binders (incl type lambdas) simplExprF1 env expr@(Case scrut bndr _ alts) cont - | not (seCaseCase env) -- See (COC-INV) in Note [sm_case_case: switching off case continuations] - , (inner, outer) <- splitContArgs cont - , not (contIsStop outer) + | Just (inner, outer) <- splitContForNoCaseCase env cont + -- See (COC-INV) in Note [sm_case_case: switching off case continuations] = do { expr' <- simplExprC env expr inner ; rebuild env expr' outer } @@ -1312,9 +1311,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont ; simplExprF env' body cont } simplExprF1 env expr@(Let {}) cont - | not (seCaseCase env) - , (inner, outer) <- splitContArgs cont - , not (contIsStop outer) + | Just (inner, outer) <- splitContForNoCaseCase env cont = do { expr' <- simplExprC env expr inner ; rebuild env expr' outer } @@ -1340,6 +1337,18 @@ simplExprF1 env (Let (Rec pairs) body) cont simplRecE env pairs body cont +splitContForNoCaseCase :: SimplEnv -> SimplCont + -> Maybe (SimplCont, SimplCont) +-- Splits `cont` into (inner, outer), where `inner` has only +-- applications, and `outer` is non-trivial +splitContForNoCaseCase env cont + | not (seCaseCase env) + , (inner, outer) <- splitContArgs cont + , not (contIsStop outer) + = Just (inner, outer) + | otherwise + = Nothing + {- Note [Avoiding space leaks in OutType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Since the simplifier is run for multiple iterations, we need to ensure @@ -2403,43 +2412,13 @@ simplOutId env fun cont | fun `hasKey` runRWKey , ApplyToTy { sc_cont = cont1 } <- cont , ApplyToTy { sc_cont = cont2 } <- cont1 - , ApplyToVal { sc_cont = cont3, sc_arg = arg, sc_cast = arg_mco - , sc_env = arg_se, sc_hole_ty = fun_ty } <- cont2 - -- Do this even if (contIsStop cont), or if seCaseCase is off. - -- See Note [No eta-expansion in runRW#] - = do { let (_saf,arg_env) = mkAltEnv env arg_se - - overall_res_ty = contResultType cont3 - -- hole_ty is the type of the current runRW# application - - -- If the argument is a literal lambda already, take a short cut - -- This isn't just efficiency: - -- * If we don't do this we get a beta-redex every time, so the - -- simplifier keeps doing more iterations. - -- * Even more important: see Note [No eta-expansion in runRW#] - ; arg' <- case arg of - Lam s body -> do { (env', s') <- simplBinder arg_env s - ; body' <- simplExprC env' body cont3 - ; return (Lam s' body') } - -- Important: do not try to eta-expand this lambda - -- See Note [No eta-expansion in runRW#] - - _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy - ; let (m,_,_) = splitFunTy fun_ty - env' = arg_env `addNewInScopeIds` [s'] - hole_ty = mkVisFunTy m realWorldStatePrimTy overall_res_ty - ; cont' <- pushCastMCo env' arg_mco $ - ApplyToVal { sc_arg = Var s', sc_cast = MRefl - , sc_env = Simplified OkDup - , sc_cont = cont3 - , sc_hole_ty = hole_ty } - -- cont' applies to s', then K - ; body' <- simplExprC env' arg cont' - ; return (Lam s' body') } - - ; let rr' = getRuntimeRep overall_res_ty - call' = mkApps (Var fun) [mkTyArg rr', mkTyArg overall_res_ty, arg'] - ; return (emptyFloats env, call') } + , ApplyToVal { sc_cont = cont3, sc_arg = arg, sc_env = arg_se + , sc_cast = arg_mco, sc_hole_ty = fun_ty } <- cont2 + = case splitContForNoCaseCase env cont3 of + Nothing -> do { e' <- simplRunRW env fun arg arg_se arg_mco fun_ty cont3 + ; return (emptyFloats env, e') } + Just (ink,outk) -> do { e' <- simplRunRW env fun arg arg_se arg_mco fun_ty ink + ; rebuild env e' outk } -- Normal case for (f e1 .. en) simplOutId env fun cont @@ -2474,6 +2453,51 @@ simplOutId env fun cont ; rebuildCall env arg_info cont } } } } } +simplRunRW :: SimplEnv + -> OutId -- runRW# + -> CoreExpr -- Main value argument `e` of runRW# + -> StaticEnv -- ...and its static envt + -> MOutCoercion -- ...and its MCoercion + -> OutType -- Type of (runRW# @k @ty), always t1->t2 + -> SimplCont -- Continuation to push into body of `e` + -> SimplM OutExpr +simplRunRW env fun arg arg_se arg_mco fun_ty cont + -- Do this even if (contIsStop cont), or if seCaseCase is off. + -- See Note [No eta-expansion in runRW#] + = do { let (_saf,arg_env) = mkAltEnv env arg_se + + overall_res_ty = contResultType cont + -- hole_ty is the type of the current runRW# application + + -- If the argument is a literal lambda already, take a short cut + -- This isn't just efficiency: + -- * If we don't do this we get a beta-redex every time, so the + -- simplifier keeps doing more iterations. + -- * Even more important: see Note [No eta-expansion in runRW#] + ; arg' <- case arg of + Lam s body -> do { (env', s') <- simplBinder arg_env s + ; body' <- simplExprC env' body cont + ; return (Lam s' body') } + -- Important: do not try to eta-expand this lambda + -- See Note [No eta-expansion in runRW#] + + _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy + ; let (m,_,_) = splitFunTy fun_ty + env' = arg_env `addNewInScopeIds` [s'] + hole_ty = mkVisFunTy m realWorldStatePrimTy overall_res_ty + ; cont' <- pushCastMCo env' arg_mco $ + ApplyToVal { sc_arg = Var s', sc_cast = MRefl + , sc_env = Simplified OkDup + , sc_cont = cont + , sc_hole_ty = hole_ty } + -- cont' applies to s', then K + ; body' <- simplExprC env' arg cont' + ; return (Lam s' body') } + + ; let rr' = getRuntimeRep overall_res_ty + call' = mkApps (Var fun) [mkTyArg rr', mkTyArg overall_res_ty, arg'] + ; return call' } + --------------------------------------------------------- -- Dealing with a call site ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -176,7 +176,7 @@ data SimplCont , sc_cont :: SimplCont } | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ] - { sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) + { sc_hole_ty :: OutType -- Type of the function, presumably (ty1 -> ty2) -- See Note [The hole type in ApplyToTy] , sc_env :: StaticEnv -- See Note [StaticEnv] , sc_arg :: CoreExpr -- The argument View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/192182385aa9c179816875d1312a8a4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/192182385aa9c179816875d1312a8a4… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/T27828] More refactoring
by Simon Peyton Jones (＠simonpj) 23 Sep '26

23 Sep '26

Simon Peyton Jones pushed to branch wip/T27828 at Glasgow Haskell Compiler / GHC Commits: 500bcd9f by Simon Peyton Jones at 2026-09-23T15:45:44+01:00 More refactoring TODO: explain why we need noEarlierMatchCheck - - - - - 4 changed files: - compiler/GHC/Core/Coercion/Axiom.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Tc/Solver/FunDeps.hs Changes: ===================================== compiler/GHC/Core/Coercion/Axiom.hs ===================================== @@ -197,14 +197,19 @@ Note [Storing compatibility] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ During axiom application, we need to be aware of which branches are compatible with which others. The full explanation is in Note [Compatibility] in -GHc.Core.FamInstEnv. (The code is placed there to avoid a dependency from +GHC.Core.FamInstEnv. (The code is placed there to avoid a dependency from GHC.Core.Coercion.Axiom on the unification algorithm.) Although we could theoretically compute compatibility on the fly, this is silly, so we store it in a CoAxiom. -Specifically, each branch refers to all other branches with which it is -incompatible. This list might well be empty, and it will always be for the -first branch of any axiom. +Specifically, the `cab_incomps :: [CoAxBranch]` field of a `CoAxBranch` +lists all /earlier/ branches with which it is /incompatible/. That is, +earlier branches where + 1) the patterns are not apart from the patterns of this branch, and + 2) if the patterns unify, the rhss are different + +This list might well be empty, and it will always be for the first branch of +any axiom. CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk stored in cab_incomps. The incompatibilities are properly a property of the ===================================== compiler/GHC/Core/FamInstEnv.hs ===================================== @@ -19,7 +19,7 @@ module GHC.Core.FamInstEnv ( FamInstMatch(..), lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, - isDominatedBy, apartnessCheck, compatibleBranches, + isDominatedBy, apartnessCheck, noEarlierMatchCheck, compatibleBranches, -- Injectivity InjectivityCheckResult(..), @@ -488,9 +488,11 @@ in GHC.Core.Unify.) Note [Compatibility] ~~~~~~~~~~~~~~~~~~~~ Two patterns are /compatible/ if either of the following conditions hold: -1) The patterns are apart. -2) The patterns unify with a substitution S, and their right hand sides -equal under that substitution. + + 1) The patterns are apart. + + 2) The patterns unify with a substitution S, and their right hand sides + are equal under that substitution. For open type families, only compatible instances are allowed. For closed type families, the story is slightly more complicated. Consider the following: @@ -603,8 +605,7 @@ injectiveBranches injectivity ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) -- See Note [Verifying injectivity annotation], case 1. - = case tcUnifyTysForInjectivity True [rhs1] [rhs2] of - -- True = two-way pre-unification + = case tcUnifyTysForInjectivity Unifying [rhs1] [rhs2] of Nothing -> InjectivityAccepted -- RHS are different, so equations are injective. -- This is case 1A from Note [Verifying injectivity annotation] @@ -1258,6 +1259,17 @@ apartnessCheck target (CoAxBranch { cab_incomps = incomps }) isSurelyApart SurelyApart = True isSurelyApart _ = False +-- | Check whether an earlier branch matches these target types +noEarlierMatchCheck + :: [Type] + -> CoAxBranch -- ^ The candidate equation we wish to use + -> Bool -- ^ True <=> equation can fire +noEarlierMatchCheck target (CoAxBranch { cab_incomps = incomps }) + = not (any matches incomps) + where + matches earlier_branch + = isJust (tcMatchTys (coAxBranchLHS earlier_branch) target) + {- ************************************************************************ * * ===================================== compiler/GHC/Core/Unify.hs ===================================== @@ -9,6 +9,7 @@ module GHC.Core.Unify ( tcMatchTyX_BM, ruleMatchTyKiX, -- Side-effect free unification + AmIUnifying(..), tcUnifyTy, tcUnifyTys, tcUnifyFunDeps, tcUnifyDebugger, tcUnifyTysFG, tcUnifyTysForInjectivity, BindTvFun, BindFamFun, BindFlag(..), @@ -597,14 +598,14 @@ tcMatchTyX_BM :: HasDebugCallStack => BindTvFun -> Subst -> Type -> Type -> Maybe Subst tcMatchTyX_BM bind_tv subst ty1 ty2 - = tc_match_tys_x bind_tv False subst [ty1] [ty2] + = tc_match_tys_x bind_tv IgnoreOuterKinds subst [ty1] [ty2] -- | Like 'tcMatchTy', but allows the kinds of the types to differ, -- and thus matches them as well. -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTyKi :: HasDebugCallStack => Type -> Type -> Maybe Subst tcMatchTyKi ty1 ty2 - = tc_match_tys alwaysBindTv True [ty1] [ty2] + = tc_match_tys alwaysBindTv CheckOuterKinds [ty1] [ty2] -- | This is similar to 'tcMatchTy', but extends a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] @@ -614,7 +615,7 @@ tcMatchTyX :: HasDebugCallStack -> Type -- ^ Target -> Maybe Subst tcMatchTyX subst ty1 ty2 - = tc_match_tys_x alwaysBindTv False subst [ty1] [ty2] + = tc_match_tys_x alwaysBindTv IgnoreOuterKinds subst [ty1] [ty2] -- | Like 'tcMatchTy' but over a list of types. -- See also Note [tcMatchTy vs tcMatchTyKi] @@ -625,7 +626,7 @@ tcMatchTys :: HasDebugCallStack -- variables could be free in the target -- See (CU6) in Note [The Core unifier] tcMatchTys tys1 tys2 - = tc_match_tys alwaysBindTv False tys1 tys2 + = tc_match_tys alwaysBindTv IgnoreOuterKinds tys1 tys2 -- | Like 'tcMatchTyKi' but over a list of types. -- See also Note [tcMatchTy vs tcMatchTyKi] @@ -635,7 +636,7 @@ tcMatchTyKis :: HasDebugCallStack -> Maybe Subst -- ^ One-shot substitution -- See (CU6) in Note [The Core unifier] tcMatchTyKis tys1 tys2 - = tc_match_tys alwaysBindTv True tys1 tys2 + = tc_match_tys alwaysBindTv CheckOuterKinds tys1 tys2 -- | Like 'tcMatchTys', but extending a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] @@ -645,7 +646,7 @@ tcMatchTysX :: HasDebugCallStack -> [Type] -- ^ Target -> Maybe Subst -- ^ One-shot substitution tcMatchTysX subst tys1 tys2 - = tc_match_tys_x alwaysBindTv False subst tys1 tys2 + = tc_match_tys_x alwaysBindTv IgnoreOuterKinds subst tys1 tys2 -- | Like 'tcMatchTyKis', but extending a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] @@ -655,12 +656,12 @@ tcMatchTyKisX :: HasDebugCallStack -> [Type] -- ^ Target -> Maybe Subst -- ^ One-shot substitution tcMatchTyKisX subst tys1 tys2 - = tc_match_tys_x alwaysBindTv True subst tys1 tys2 + = tc_match_tys_x alwaysBindTv CheckOuterKinds subst tys1 tys2 -- | Same as tc_match_tys_x, but starts with an empty substitution tc_match_tys :: HasDebugCallStack => BindTvFun - -> Bool -- ^ match kinds? + -> OuterKindsFlag -- ^ Match kinds? -> [Type] -> [Type] -> Maybe Subst @@ -672,7 +673,7 @@ tc_match_tys bind_me match_kis tys1 tys2 -- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' tc_match_tys_x :: HasDebugCallStack => BindTvFun - -> Bool -- ^ match kinds? + -> OuterKindsFlag -- ^ Match kinds? -> Subst -> [Type] -> [Type] @@ -680,8 +681,8 @@ tc_match_tys_x :: HasDebugCallStack tc_match_tys_x bind_tv match_kis (Subst in_scope id_env tv_env cv_env) tys1 tys2 = case tc_unify_tys neverBindFam -- (ATF7) in Note [Apartness and type families] bind_tv - False -- Matching, not unifying - False -- Not an injectivity check + Matching -- Matching, not unifying + False -- Not an injectivity check match_kis RespectMultiplicities (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of @@ -706,9 +707,9 @@ ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target -- But even if it did, (ATF8) in Note [Apartness and type families] -- says it doesn't matter becuase here we only care about Unifiable. -- So neverBindFam is efficient, and sufficient. - False -- Matching, not unifying + Matching -- Matching, not unifying False -- No doing an injectivity check - True -- Match the kinds + CheckOuterKinds -- Match the kinds IgnoreMultiplicities -- See Note [Rewrite rules ignore multiplicities in FunTy] rn_env tenv emptyCvSubstEnv [tmpl] [target] of @@ -784,7 +785,7 @@ tcUnifyTy t1 t2 = tcUnifyTys alwaysBindTv [t1] [t2] tcUnifyDebugger :: Type -> Type -> Maybe Subst tcUnifyDebugger t1 t2 = case tc_unify_tys_fg - True -- Unify kinds + CheckOuterKinds -- Unify kinds neverBindFam -- Does not affect Unifiable, so pick max efficient -- See (ATF8) in Note [Apartness and type families] alwaysBindTv @@ -798,7 +799,7 @@ tcUnifyFunDeps :: TyCoVarSet -> Maybe Subst tcUnifyFunDeps qtvs tys1 tys2 = case tc_unify_tys_fg - True -- Unify kinds + CheckOuterKinds -- Unify kinds dontCareBindFam -- Class-instance heads never mention type families (matchBindTv qtvs) tys1 tys2 of @@ -821,7 +822,7 @@ tcUnifyTysForInjectivity unif tys1 tys2 = case tc_unify_tys alwaysBindFam alwaysBindTv unif -- Am I unifying? True -- Do injectivity checks - False -- Don't check outermost kinds + IgnoreOuterKinds -- Don't check outermost kinds RespectMultiplicities rn_env emptyTvSubstEnv emptyCvSubstEnv tys1 tys2 of @@ -838,8 +839,9 @@ tcUnifyTysForInjectivity unif tys1 tys2 -- should never actually be done maybe_fix tv_subst - | unif = niFixSubst in_scope tv_subst - | otherwise = mkTvSubst in_scope tv_subst + = case unif of + Unifying -> niFixSubst in_scope tv_subst + Matching -> mkTvSubst in_scope tv_subst -- When matching, don't confuse domain with range; no fixpoint! ----------------- @@ -866,15 +868,15 @@ tcUnifyTysFG :: BindFamFun -> BindTvFun -> [Type] -> [Type] -> UnifyResult tcUnifyTysFG bind_fam bind_tv tys1 tys2 - = tc_unify_tys_fg False bind_fam bind_tv tys1 tys2 + = tc_unify_tys_fg IgnoreOuterKinds bind_fam bind_tv tys1 tys2 -tc_unify_tys_fg :: Bool +tc_unify_tys_fg :: OuterKindsFlag -> BindFamFun -> BindTvFun -> [Type] -> [Type] -> UnifyResult tc_unify_tys_fg match_kis bind_fam bind_tv tys1 tys2 = do { (tv_env, _) <- tc_unify_tys bind_fam bind_tv - True -- Unifying + Unifying False -- Not doing an injectivity check match_kis -- Match outer kinds RespectMultiplicities rn_env @@ -888,10 +890,10 @@ tc_unify_tys_fg match_kis bind_fam bind_tv tys1 tys2 -- | This function is actually the one to call the unifier -- a little -- too general for outside clients, though. tc_unify_tys :: BindFamFun -> BindTvFun - -> AmIUnifying -- ^ True <=> unify; False <=> match - -> Bool -- ^ True <=> doing an injectivity check - -> Bool -- ^ True <=> treat the kinds as well - -> MultiplicityFlag -- ^ see Note [Rewrite rules ignore multiplicities in FunTy] in GHC.Core.Unify + -> AmIUnifying -- ^ Unifying or matching + -> Bool -- ^ True <=> doing an injectivity check + -> OuterKindsFlag -- ^ Check outer kinds or not + -> MultiplicityFlag -- ^ see Note [Rewrite rules ignore multiplicities in FunTy] in GHC.Core.Unify -> RnEnv2 -> TvSubstEnv -- ^ substitution to extend -> CvSubstEnv @@ -910,8 +912,9 @@ tc_unify_tys :: BindFamFun -> BindTvFun -- See also Note [tcMatchTy vs tcMatchTyKi]. tc_unify_tys bind_fam bind_tv unif inj_check match_kis match_mults rn_env tv_env cv_env tys1 tys2 = initUM tv_env cv_env $ - do { when match_kis $ - unify_tys env kis1 kis2 + do { case match_kis of + CheckOuterKinds -> unify_tys env kis1 kis2 + IgnoreOuterKinds -> return () ; unify_tys env tys1 tys2 } where env = UMEnv { um_bind_tv_fun = bind_tv @@ -926,6 +929,11 @@ tc_unify_tys bind_fam bind_tv unif inj_check match_kis match_mults rn_env tv_env kis2 = map typeKind tys2 +data OuterKindsFlag + = CheckOuterKinds -- Unify or match the /kind/ of the two types + | IgnoreOuterKinds -- Just unify of match the types, ignoring kinds + -- (typically, we already know they are equal) + {- ********************************************************************* * * UnifyResult, MaybeApart etc @@ -1583,8 +1591,7 @@ c.f. Note [Comparing type synonyms] in GHC.Core.TyCo.Compare -------------- unify_ty: the main workhorse ----------- -type AmIUnifying = Bool -- True <=> Unifying - -- False <=> Matching +data AmIUnifying = Matching | Unifying type InType = Type -- Before applying the RnEnv2 type OutCoercion = Coercion -- After applying the RnEnv2 @@ -1618,7 +1625,7 @@ unify_ty env (CastTy ty1 co1) ty2 kco -- See (KCU1) in Note [Kind coercions in Unify] = maybeApart MARCast -- See (KCU2) - | um_unif env + | Unifying <- um_unif env = unify_ty env ty1 ty2 (co1 `mkTransCo` kco) | otherwise -- We are matching, not unifying @@ -1661,7 +1668,7 @@ unify_ty env (CoercionTy co1) (CoercionTy co2) kco = do { c_subst <- getCvSubstEnv ; case co1 of CoVarCo cv - | not (um_unif env) + | Matching <- um_unif env , not (cv `elemVarEnv` c_subst) -- Not forall-bound , let (_mult_co, co_l, co_r) = decomposeFunCo kco -- Because the coercion is used in a type, it should be safe to @@ -1682,7 +1689,7 @@ unify_ty env (TyVarTy tv1) ty2 kco = uVarOrFam env (TyVarLHS tv1) ty2 kco unify_ty env ty1 (TyVarTy tv2) kco - | um_unif env -- If unifying, can swap args; but not when matching + | Unifying <- um_unif env -- If unifying, can swap args; but not when matching = uVarOrFam (umSwapRn env) (TyVarLHS tv2) ty1 (mkSymCo kco) -- Deal with TyConApps @@ -1692,7 +1699,7 @@ unify_ty env ty1 ty2 kco | Just (tc,tys) <- mb_sat_fam_app1 = uVarOrFam env (TyFamLHS tc tys) ty2 kco - | um_unif env + | Unifying <- um_unif env , Just (tc,tys) <- mb_sat_fam_app2 = uVarOrFam (umSwapRn env) (TyFamLHS tc tys) ty1 (mkSymCo kco) @@ -1820,7 +1827,7 @@ uVarOrFam env ty1 ty2 kco go swapped substs lhs@(TyVarLHS tv1) ty2 kco | Just ty1' <- lookupVarEnv (um_tv_env substs) tv1' = -- We already have a substitution for tv1 - if | um_unif env -> unify_ty env ty1' ty2 kco + if | Unifying <- um_unif env -> unify_ty env ty1' ty2 kco | (ty1' `mkCastTy` kco) `tcEqType` ty2 -> return () | otherwise -> surelyApart -- Unifying: recurse into unify_ty @@ -1842,9 +1849,9 @@ uVarOrFam env ty1 ty2 kco | TyVarTy tv2 <- ty2 , let tv2' = umRnOccR env tv2 , tv1' == tv2' - = if | um_unif env -> return () - | tv1_is_bindable -> extendTvEnv tv1' ty2 - | otherwise -> return () + = if | Unifying <- um_unif env -> return () + | tv1_is_bindable -> extendTvEnv tv1' ty2 + | otherwise -> return () | tv1_is_bindable , not (mentionsForAllBoundTyVarsR env ty2_fvs) @@ -1858,9 +1865,9 @@ uVarOrFam env ty1 ty2 kco -- e.g. a ~ F p q with `a` not bindable: we might succeed with go_fam -- e.g. a ~ beta with `a` not bindable: we might be able to bind `beta` -- e.g. beta ~ F beta Int occurs check; but MaybeApart after swapping - | um_unif env + | Unifying <- um_unif env , NotSwapped <- swapped -- If we have swapped already, don't do so again - , Just lhs2 <- canEqLHS_maybe ty2 + , Just lhs2 <- canEqLHS_maybe ty2 = go IsSwapped substs lhs2 (mkTyVarTy tv1) (mkSymCo kco) | occurs_check = maybeApart MARInfinite -- Occurs check @@ -1879,7 +1886,9 @@ uVarOrFam env ty1 ty2 kco | otherwise = False - occurs_check = um_unif env && uOccursCheck substs foralld_tvs lhs rhs + occurs_check = case um_unif env of + Unifying -> uOccursCheck substs foralld_tvs lhs rhs + Matching -> False -- Occurs check, only when unifying -- see Note [Infinitary substitutions] -- Make sure you include `kco` in rhs #14846 @@ -1893,7 +1902,7 @@ uVarOrFam env ty1 ty2 kco -- Hence the RnEnv2 is empty | not under_forall , Just ty1' <- lookupFamEnv (um_fam_env substs) tc1 tys1 - = if | um_unif env -> unify_ty env ty1' ty2 kco + = if | Unifying <- um_unif env -> unify_ty env ty1' ty2 kco -- Below here we are matching -- The return () case deals with: -- Template: (F a)..(F a) @@ -1930,9 +1939,9 @@ uVarOrFam env ty1 ty2 kco -- NB: a type family can appear on the template when matching -- see (ATF6) in Note [Apartness and type families] -- (Only worth doing this if we are not under a forall.) - | um_unif env + | Unifying <- um_unif env , NotSwapped <- swapped - , Just lhs2 <- canEqLHS_maybe ty2 + , Just lhs2 <- canEqLHS_maybe ty2 = go IsSwapped substs lhs2 (mkTyConApp tc1 tys1) (mkSymCo kco) | otherwise -- See (ATF5) in Note [Apartness and type families] @@ -1962,9 +1971,9 @@ uVarOrFam env ty1 ty2 kco (inj_tys2, noninj_tys2) = partitionByList inj tys2 bind_fam_if_poss - | not (um_unif env) -- Not when matching (ATF11-1) + | Matching <- um_unif env -- Not when matching (ATF11-1) = return () - | under_forall -- Not under a forall (ATF3) + | under_forall -- Not under a forall (ATF3) = return () | BindMe <- um_bind_fam_fun env tc tys1 rhs1 = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys1) rhs1) $ ===================================== compiler/GHC/Tc/Solver/FunDeps.hs ===================================== @@ -26,7 +26,8 @@ import GHC.Core.Coercion import GHC.Core.TyCo.Rep( Type(..) ) import GHC.Core.Predicate( EqRel(..) ) import GHC.Core.TyCon -import GHC.Core.Unify( tcUnifyTysForInjectivity, typeListsAreApart ) +import GHC.Core.Unify( AmIUnifying(..) + , tcUnifyTysForInjectivity, typeListsAreApart ) import GHC.Core.Coercion.Axiom import GHC.Core.TyCo.Subst( elemSubst ) @@ -685,7 +686,7 @@ hasRelevantGiven eqs_for_me work_args (EqCt { eq_rhs = work_rhs }) relevant (EqCt { eq_ev = ev, eq_lhs = lhs, eq_rhs = rhs_ty }) | isGiven ev , TyFamLHS _ lhs_tys <- lhs - = isJust (tcUnifyTysForInjectivity True work_tys (rhs_ty:lhs_tys)) + = isJust (tcUnifyTysForInjectivity Unifying work_tys (rhs_ty:lhs_tys)) | otherwise = False @@ -693,14 +694,15 @@ getRelevantBranches :: CoAxiom Branched -> [TcType] -> Xi -> [FunDepEqns] -- Return the FunDepEqns that arise from each relevant branch -- Implements Definition [Relevance] getRelevantBranches ax work_args work_rhs - = let res = go [] (fromBranches (coAxiomBranches ax)) - in pprTrace "getRelevantBranches" - (vcat [ text "ax" <+> ppr ax - , text "work_args" <+> ppr work_args - , text "work_rhs" <+> ppr work_rhs - , text "work_tys" <+> ppr work_tys - , text "res" <+> ppr res]) - res + = go [] (fromBranches (coAxiomBranches ax)) +-- = let res = go [] (fromBranches (coAxiomBranches ax)) +-- in pprTrace "getRelevantBranches" +-- (vcat [ text "ax" <+> ppr ax +-- , text "work_args" <+> ppr work_args +-- , text "work_rhs" <+> ppr work_rhs +-- , text "work_tys" <+> ppr work_tys +-- , text "res" <+> ppr res]) +-- res where work_tys = work_rhs : work_args @@ -713,7 +715,7 @@ getRelevantBranches ax work_args work_rhs is_relevant branch@(CoAxBranch { cab_tvs = qtvs , cab_lhs = lhs_tys , cab_rhs = rhs_ty }) - | Just subst <- tcUnifyTysForInjectivity True (rhs_ty:lhs_tys) work_tys + | Just subst <- tcUnifyTysForInjectivity Unifying (rhs_ty:lhs_tys) work_tys -- See (RW1)-(RW3) in Note [Relevance] -- This is a pre-/unification/ check (not matching) -- so `subst` can bind both `qtvs` and fvs(work_tys) @@ -721,7 +723,7 @@ getRelevantBranches ax work_args work_rhs lhs_tys' = substTys subst' lhs_tys rhs_ty' = substTy subst' rhs_ty branch_tys' = rhs_ty' : lhs_tys' - , apartnessCheck lhs_tys' branch -- See (RW4) in Note [Relevance] + , noEarlierMatchCheck lhs_tys' branch -- See (RW4) in Note [Relevance] = Just (FDEqns { fd_qtvs = qtvs' , fd_eqs = zipWith Pair branch_tys' work_tys }) -- Do not apply the substition to `work_tys`; @@ -742,8 +744,7 @@ mkTopOpenFamEqFDs fam_tc inj_flags work_args (EqCt { eq_rhs = work_rhs }) do_one (CoAxBranch { cab_tvs = branch_qtvs , cab_lhs = branch_lhs_tys , cab_rhs = branch_rhs }) - | Just subst <- tcUnifyTysForInjectivity False [branch_rhs] [work_rhs] - -- False: matching, not unifying + | Just subst <- tcUnifyTysForInjectivity Matching [branch_rhs] [work_rhs] , let (subst', qtvs') = trim_qtvs subst branch_qtvs branch_lhs_tys' = substTys subst' branch_lhs_tys -- ToDo @@ -1075,7 +1076,7 @@ Note [Exploiting closed type families]. A watertight proof that this is the Right Thing is not very easy. See more discussion in #23162, and Section 5.2 of the paper. - This test is immplemented in `apartnessCheck` in `getRelevantBranches`. + This test is implemented in `apartnessCheck` in `getRelevantBranches`. Note [Exploiting open type families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/500bcd9f97f5ff9e157b688bb701016… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/500bcd9f97f5ff9e157b688bb701016… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/apk/rts-flag-fixes] RTS: Update flag parsing/handling:
by Andreas Klebinger (＠AndreasK) 23 Sep '26

23 Sep '26

Andreas Klebinger pushed to branch wip/apk/rts-flag-fixes at Glasgow Haskell Compiler / GHC Commits: 580ccb23 by Andreas Klebinger at 2026-09-23T14:28:57+00:00 RTS: Update flag parsing/handling: Using 0 as argument to any of these flags now resets the flags setting to default: - ``-n0`` disables nursery chunking. - ``-K0`` (or a bare ``-K``) removes the stack size limit. - ``-M0`` removes the heap size limit. - ``-H0`` resets the suggested heap size, including the nursery scaling set by ``-H``. - ``-AL0`` makes the large object allocation limit follow ``-A`` again. GC Generations are now limited to 64. -n larger than -A now emits a warning and disables chunking. Fixes #27830 #27829 - - - - - 10 changed files: - + changelog.d/T27830-rts-flag-bounds - docs/users_guide/runtime_control.rst - rts/RtsFlags.c - rts/include/rts/Flags.h - rts/include/rts/storage/GC.h - rts/sm/GC.c - rts/sm/Storage.c - testsuite/tests/rts/all.T - testsuite/tests/rts/rtsflags001.stderr-ws-32 - testsuite/tests/rts/rtsflags001.stderr-ws-64 Changes: ===================================== changelog.d/T27830-rts-flag-bounds ===================================== @@ -0,0 +1,17 @@ +section: rts +synopsis: Update RTS flag handling: It now respects user set -n values, allows resetting of more settings to defaults and gives more accurate bounds in errors. +description: + Using 0 as argument to any of these flags now resets the flags setting to default: + + - ``-n0`` disables nursery chunking. + - ``-K0`` (or a bare ``-K``) removes the stack size limit. + - ``-M0`` removes the heap size limit. + - ``-H0`` resets the suggested heap size, including the nursery scaling set by ``-H``. + - ``-AL0`` makes the large object allocation limit follow ``-A`` again. + + A nursery chunk size (``-n``) larger than the allocation area (``-A``) now prints a + warning and disables nursery chunking. Previously every nursery was enlarged to the chunk size. + + The number of generations (``-G``) is now limited to 64. +issues: #27830 #27829 +mrs: !16713 ===================================== docs/users_guide/runtime_control.rst ===================================== @@ -493,7 +493,7 @@ performance. Sets the limit on the total size of "large objects" (objects larger than about 3KB) that can be allocated before a GC is triggered. By default this limit is the same as the :rts-flag:`-A <-A - ⟨size⟩>` value. + ⟨size⟩>` value. ``-AL0`` restores the default. Large objects are not allocated from the normal allocation area set by the ``-A`` flag, which is why there is a separate limit for @@ -635,10 +635,11 @@ performance. Set the number of generations used by the garbage collector. The default of 2 seems to be good, but the garbage - collector can support any number of generations. Anything larger + collector can in theory support any number of generations. Anything larger than about 4 is probably not a good idea unless your program runs for a *long* time, because the oldest generation will hardly ever - get collected. + get collected. Currently the RTS hardcodes a limit of 64 generations which + seems plenty. Specifying 1 generation with ``+RTS -G1`` gives you a simple 2-space collector, as you would expect. In a 2-space collector, the :rts-flag:`-A @@ -731,6 +732,9 @@ performance. the default small ``-A`` value is suboptimal, as it can be in programs that create large amounts of long-lived data. + ``-H0`` resets both the size suggestion, and dynamic scaling enablied by a + bare ``-H``. + .. rts-flag:: -I ⟨seconds⟩ :default: 0.3 seconds in the threaded runtime, 0 in the non-threaded runtime @@ -886,7 +890,7 @@ performance. of the program. The only reason for having this option is to stop the heap growing without bound and filling up all the available swap space, which at the least will result in the program being summarily - killed by the operating system. + killed by the operating system. ``-M0`` resets any limit set by ``-M<size>``. The maximum heap size also affects other garbage collection parameters: when the amount of live data in the heap exceeds a ===================================== rts/RtsFlags.c ===================================== @@ -101,7 +101,8 @@ static int openStatsFile ( char *filename, const char *FILENAME_FMT, FILE **file_ret); static StgWord64 decodeSize ( - const char *flag, uint32_t offset, StgWord64 min, StgWord64 max); + const char *flag, uint32_t offset, StgWord64 min, StgWord64 max, + bool allow_zero); static double parseDouble ( const char *arg, bool *error); @@ -141,8 +142,8 @@ void initRtsFlagsDefaults(void) if (maxStkSize == 0) maxStkSize = 8 * 1024 * 1024; // GcFlags.maxStkSiz is 32-bit, so we need to cap to prevent overflow (#17019) - else if (maxStkSize > UINT32_MAX * sizeof(W_)) - maxStkSize = UINT32_MAX * sizeof(W_); + else if (maxStkSize > (StgWord64) UINT32_MAX * sizeof(W_)) + maxStkSize = (StgWord64) UINT32_MAX * sizeof(W_); RtsFlags.GcFlags.statsFile = NULL; RtsFlags.GcFlags.giveStats = NO_GC_STATS; @@ -155,7 +156,7 @@ void initRtsFlagsDefaults(void) /* -A default. See #16499 for a discussion about the tradeoffs */ RtsFlags.GcFlags.minAllocAreaSize = (4 * 1024 * 1024) / BLOCK_SIZE; RtsFlags.GcFlags.largeAllocLim = 0; /* defaults to minAllocAreasize */ - RtsFlags.GcFlags.nurseryChunkSize = 0; + RtsFlags.GcFlags.nurseryChunkSize = -1; /* -1: Nothing set by user, normalized to off by default, 0: off explicitly, <n>: explicit size*/ RtsFlags.GcFlags.minOldGenSize = (1024 * 1024) / BLOCK_SIZE; /* -O default */ RtsFlags.GcFlags.maxHeapSize = 0; /* off by default */ RtsFlags.GcFlags.heapLimitGrace = (1024 * 1024); @@ -331,7 +332,7 @@ usage_text[] = { " --copying-gc", " Selects the copying garbage collector to manage all generations.", "", -" -K<size> Sets the maximum stack size (default: 80% of the heap)", +" -K<size> Sets the maximum stack size (0 = unlimited, default: 80% of the heap)", " e.g.: -K32k -K512k -K8M", " -ki<size> Sets the initial thread stack size (default 1k) e.g.: -ki4k -ki2m", " -kc<size> Sets the stack chunk size (default 32k)", @@ -349,9 +350,9 @@ usage_text[] = { " memory controlled by this factor (higher is slower). Setting the factor", " to 0 means memory is not returned.", " (default 4.0)", -" -n<size> Allocation area chunk size (0 = disabled, default: 0)", +" -n<size> Allocation area chunk size (0 = disabled, default: 0, 4m for -A >= 16m)", " -O<size> Sets the minimum size of the old generation (default 1M)", -" -M<size> Sets the maximum heap size (default unlimited) e.g.: -M256k -M1G", +" -M<size> Sets the maximum heap size (0 = unlimited, default unlimited) e.g.: -M256k -M1G", " -H<size> Sets the minimum heap size (default 0M) e.g.: -H24m -H1G", " -xb<addr> Sets the address from which a suitable start for the heap memory", " will be searched from. This is useful if the default address", @@ -1239,19 +1240,19 @@ error = true; if (rts_argv[arg][2] == 'L') { RtsFlags.GcFlags.largeAllocLim = decodeSize(rts_argv[arg], 3, 2*BLOCK_SIZE, - HS_INT_MAX) / BLOCK_SIZE; + (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, true) / BLOCK_SIZE; } else { // minimum two blocks in the nursery, so that we have one // to grab for allocate(). RtsFlags.GcFlags.minAllocAreaSize = decodeSize(rts_argv[arg], 2, 2*BLOCK_SIZE, - HS_INT_MAX) / BLOCK_SIZE; + (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, false) / BLOCK_SIZE; } break; case 'n': OPTION_UNSAFE; RtsFlags.GcFlags.nurseryChunkSize - = decodeSize(rts_argv[arg], 2, 2*BLOCK_SIZE, HS_INT_MAX) + = decodeSize(rts_argv[arg], 2, 2*BLOCK_SIZE, ((StgWord64) HS_INT32_MAX) * BLOCK_SIZE, true) / BLOCK_SIZE; break; @@ -1301,9 +1302,14 @@ error = true; case 'K': OPTION_UNSAFE; - RtsFlags.GcFlags.maxStkSize = - decodeSize(rts_argv[arg], 2, 0, UINT32_MAX) - / sizeof(W_); + // -K and -K0 mean unlimited. + if (rts_argv[arg][2] == '\0') { + RtsFlags.GcFlags.maxStkSize = 0; + } else { + RtsFlags.GcFlags.maxStkSize = + decodeSize(rts_argv[arg], 2, sizeof(W_), (StgWord64) UINT32_MAX * sizeof(W_), true) + / sizeof(W_); + } break; case 'k': @@ -1311,22 +1317,22 @@ error = true; switch(rts_argv[arg][2]) { case 'c': RtsFlags.GcFlags.stkChunkSize = - decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) + decodeSize(rts_argv[arg], 3, sizeof(W_), (StgWord64)HS_WORD32_MAX * sizeof(W_), false) / sizeof(W_); break; case 'b': RtsFlags.GcFlags.stkChunkBufferSize = - decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) + decodeSize(rts_argv[arg], 3, sizeof(W_), (StgWord64)HS_WORD32_MAX * sizeof(W_), false) / sizeof(W_); break; case 'i': RtsFlags.GcFlags.initialStkSize = - decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) + decodeSize(rts_argv[arg], 3, sizeof(W_), (StgWord64)HS_WORD32_MAX * sizeof(W_), false) / sizeof(W_); break; default: RtsFlags.GcFlags.initialStkSize = - decodeSize(rts_argv[arg], 2, sizeof(W_), HS_WORD_MAX) + decodeSize(rts_argv[arg], 2, sizeof(W_), (StgWord64)HS_WORD32_MAX * sizeof(W_), false) / sizeof(W_); break; } @@ -1336,10 +1342,10 @@ error = true; OPTION_UNSAFE; if (0 == strncmp("grace=", rts_argv[arg] + 2, 6)) { RtsFlags.GcFlags.heapLimitGrace = - decodeSize(rts_argv[arg], 8, BLOCK_SIZE, HS_WORD_MAX); + decodeSize(rts_argv[arg], 8, BLOCK_SIZE, HS_WORD_MAX, false); } else { RtsFlags.GcFlags.maxHeapSize = - decodeSize(rts_argv[arg], 2, BLOCK_SIZE, HS_WORD_MAX) + decodeSize(rts_argv[arg], 2, BLOCK_SIZE, (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, true) / BLOCK_SIZE; // user give size in *bytes* but "maxHeapSize" is in // *blocks* @@ -1388,8 +1394,9 @@ error = true; #endif case 'G': OPTION_UNSAFE; - RtsFlags.GcFlags.generations = - decodeSize(rts_argv[arg], 2, 1, HS_INT_MAX); + // Capped at 64 by hardcoded array size in non-threaded RTS. + RtsFlags.GcFlags.generations = (uint32_t) + decodeSize(rts_argv[arg], 2, 1, GC_MAX_GENERATIONS, false); break; case 'H': @@ -1398,8 +1405,12 @@ error = true; RtsFlags.GcFlags.heapSizeSuggestionAuto = true; } else { RtsFlags.GcFlags.heapSizeSuggestion = (uint32_t) - (decodeSize(rts_argv[arg], 2, BLOCK_SIZE, HS_WORD_MAX) + (decodeSize(rts_argv[arg], 2, BLOCK_SIZE, (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, true) / BLOCK_SIZE); + // -H0 resets to the default of no suggestion. + if (RtsFlags.GcFlags.heapSizeSuggestion == 0) { + RtsFlags.GcFlags.heapSizeSuggestionAuto = false; + } } break; @@ -1407,7 +1418,7 @@ error = true; OPTION_UNSAFE; RtsFlags.GcFlags.minOldGenSize = (uint32_t)(decodeSize(rts_argv[arg], 2, BLOCK_SIZE, - HS_WORD_MAX) + (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, false) / BLOCK_SIZE); break; @@ -1852,14 +1863,14 @@ error = true; case 'q': OPTION_UNSAFE; RtsFlags.GcFlags.allocLimitGrace - = decodeSize(rts_argv[arg], 3, BLOCK_SIZE, HS_INT_MAX) + = decodeSize(rts_argv[arg], 3, BLOCK_SIZE, HS_INT_MAX, false) / BLOCK_SIZE; break; case 'r': OPTION_UNSAFE; RtsFlags.GcFlags.addressSpaceSize - = decodeSize(rts_argv[arg], 3, MBLOCK_SIZE, HS_WORD64_MAX); + = decodeSize(rts_argv[arg], 3, MBLOCK_SIZE, HS_WORD64_MAX, false); break; default: @@ -1994,9 +2005,25 @@ static void normaliseRtsOpts (void) RtsFlags.GcFlags.minAllocAreaSize = RtsFlags.GcFlags.maxHeapSize; } - // If we have -A16m or larger, use -n4m. - if (RtsFlags.GcFlags.minAllocAreaSize >= (16*1024*1024) / BLOCK_SIZE) { - RtsFlags.GcFlags.nurseryChunkSize = (4*1024*1024) / BLOCK_SIZE; + // If no explicit size was given, and we have -A16m or larger, use -n4m. + if (RtsFlags.GcFlags.nurseryChunkSize == -1) { + if (RtsFlags.GcFlags.minAllocAreaSize >= (16*1024*1024) / BLOCK_SIZE) { + RtsFlags.GcFlags.nurseryChunkSize = (4*1024*1024) / BLOCK_SIZE; + } else { + RtsFlags.GcFlags.nurseryChunkSize = 0; + } + } + else if ( RtsFlags.GcFlags.nurseryChunkSize > 0 && RtsFlags.GcFlags.nurseryChunkSize < 2) { + errorBelch("nursery chunk size (-n) must be at least %" FMT_Word " large.", (W_)(2 * BLOCK_SIZE)); + errorBelch("Disabling nursery chunking"); + RtsFlags.GcFlags.nurseryChunkSize = 0; + } + // If the user gave a chunk size respect it, unless it's larger than + // minimum allocation area. + else if ( (StgWord64) RtsFlags.GcFlags.nurseryChunkSize > (StgWord64) RtsFlags.GcFlags.minAllocAreaSize) { + errorBelch("warning: nursery chunk size (-n) is bigger than minimum alloc area size (-A), " + "disabling nursery chunking"); + RtsFlags.GcFlags.nurseryChunkSize = 0; } if (RtsFlags.ParFlags.parGcLoadBalancingGen == ~0u) { @@ -2144,10 +2171,14 @@ static void initStatsFile (FILE *f) /* ----------------------------------------------------------------------------- * decodeSize: parse a string containing a size, like 300K or 1.2M + * + * The result must lie within [min, max]. If allow_zero is set an explicitly + * given zero (e.g. "-M0") is accepted as well. -------------------------------------------------------------------------- */ static StgWord64 -decodeSize(const char *flag, uint32_t offset, StgWord64 min, StgWord64 max) +decodeSize(const char *flag, uint32_t offset, StgWord64 min, StgWord64 max, + bool allow_zero) { const char *s; StgDouble m; @@ -2206,10 +2237,14 @@ decodeSize(const char *flag, uint32_t offset, StgWord64 min, StgWord64 max) val = (StgWord64)m; - if (m < 0 || val < min || val > max) { - // printf doesn't like 64-bit format specs on Windows - // apparently, so fall back to unsigned long. - errorBelch("error in RTS option %s: size outside allowed range (%" FMT_Word " - %" FMT_Word ")", flag, (W_)min, (W_)max); + // Only a explicit zero-digit is accepted for allow_zero. + bool explicit_zero = allow_zero && *s != '\0' && m == 0; + if (m < 0 || (val < min && !explicit_zero) || val > max) { + if (allow_zero && min > 0) { + errorBelch("error in RTS option %s: size outside allowed range (0 or %" FMT_Word64 " - %" FMT_Word64 ")", flag, (StgWord64)min, (StgWord64)max); + } else { + errorBelch("error in RTS option %s: size outside allowed range (%" FMT_Word64 " - %" FMT_Word64 ")", flag, (StgWord64)min, (StgWord64)max); + } stg_exit(EXIT_FAILURE); } ===================================== rts/include/rts/Flags.h ===================================== @@ -45,7 +45,7 @@ typedef struct _GC_FLAGS { uint32_t maxHeapSize; /* in *blocks* */ uint32_t minAllocAreaSize; /* in *blocks* */ uint32_t largeAllocLim; /* in *blocks* */ - uint32_t nurseryChunkSize; /* in *blocks* */ + int32_t nurseryChunkSize; /* in *blocks*, int to distinguish default off, vs explicit off */ uint32_t minOldGenSize; /* in *blocks* */ uint32_t heapSizeSuggestion; /* in *blocks* */ bool heapSizeSuggestionAuto; @@ -80,7 +80,7 @@ typedef struct _GC_FLAGS { * to handle the exception before we * raise it again. */ - StgWord heapLimitGrace; /* units: *blocks* + StgWord heapLimitGrace; /* units: *bytes* * After a HeapOverflow exception has * been raised, how much extra space is * given to the thread to handle the ===================================== rts/include/rts/storage/GC.h ===================================== @@ -52,6 +52,8 @@ // ie. StgWord. Note that we have had some tricky int overflows in a // couple of cases caused by using ints rather than longs (e.g. #5086) +#define GC_MAX_GENERATIONS 64 + typedef StgWord memcount; typedef struct nursery_ { ===================================== rts/sm/GC.c ===================================== @@ -154,7 +154,7 @@ static Condition gc_exit_leave_now_cv; #else // THREADED_RTS // Must match the alignment of gen_workspace. -StgWord8 the_gc_thread[sizeof(gc_thread) + 64 * sizeof(gen_workspace)] +StgWord8 the_gc_thread[sizeof(gc_thread) + GC_MAX_GENERATIONS * sizeof(gen_workspace)] ATTRIBUTE_ALIGNED(GEN_WORKSPACE_ALIGNMENT); #endif // THREADED_RTS ===================================== rts/sm/Storage.c ===================================== @@ -273,7 +273,7 @@ void storageAddCapabilities (uint32_t from, uint32_t to) if (RtsFlags.GcFlags.nurseryChunkSize == 0) { new_n_nurseries = to; } else { - memcount total_alloc = to * RtsFlags.GcFlags.minAllocAreaSize; + memcount total_alloc = to * (size_t) RtsFlags.GcFlags.minAllocAreaSize; new_n_nurseries = stg_max(to, total_alloc / RtsFlags.GcFlags.nurseryChunkSize); } ===================================== testsuite/tests/rts/all.T ===================================== @@ -171,7 +171,7 @@ test('T3424', # Test for out-of-range heap size test('rtsflags001', [ only_ways(['normal']), exit_code(1), - extra_run_opts('+RTS -H0m -RTS'), + extra_run_opts('+RTS -H1k -RTS'), js_skip # JS backend uses its own rts. ], compile_and_run, ['']) ===================================== testsuite/tests/rts/rtsflags001.stderr-ws-32 ===================================== @@ -1 +1 @@ -rtsflags001: error in RTS option -H0m: size outside allowed range (4096 - 4294967295) +rtsflags001: error in RTS option -H1k: size outside allowed range (0 or 4096 - 17592186040320) ===================================== testsuite/tests/rts/rtsflags001.stderr-ws-64 ===================================== @@ -1 +1 @@ -rtsflags001: error in RTS option -H0m: size outside allowed range (4096 - 18446744073709551615) +rtsflags001: error in RTS option -H1k: size outside allowed range (0 or 4096 - 17592186040320) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/580ccb23eba42355b87360b96edbe45… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/580ccb23eba42355b87360b96edbe45… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 50 commits: Change the C types of hs_{bitrev,bswap}{16,32} to match the Haskell types
by Alan Zimmerman (＠alanz) 23 Sep '26

23 Sep '26

Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC Commits: 545fd4fb by ARATA Mizuki at 2026-09-22T15:03:24-04:00 Change the C types of hs_{bitrev,bswap}{16,32} to match the Haskell types bitReverse{16,32}# and byteSwap{16,32}# have the type Word# -> Word#, but their C correspondents took and returned StgWord{16,32}. The mismatch on bitReverse16# led to the problem reported in #27299. Although no similar issue is reported for bitReverse32# and byteSwap{16,32}#, it seemed wise to change them proactively. This commit fixes the mismatch by changing the C type. Fixes #27299 - - - - - bf17f289 by fendor at 2026-09-22T15:04:05-04:00 Don't lose instances from shadowed imported modules with the same name When we look for instances below the current module, we need to check the unit id as well when we check for whether the module is the current module, otherwise we ignore modules we import that have the same name as the import module. Adds regression test. - - - - - bd9b258a by Alan Zimmerman at 2026-09-23T15:23:41+01:00 EPA: Add specific layout field to AnnList Up to now AnnList has effectively served to represent lists of things having layout, regardless of whether they do or not. In Haskell, layout is optional in many places, as there is also an alternative syntax using braces and semi-colons, which is free-form. This commit introduces AnnListLayout, a data structure capturing this distinction. It is deliberately set up similarly to EpLayout, so that these two can be merged in time. The transition is done mechanically, where AnnListBraces is not used yet, the original Nothing case maps to AnnListNoLayout, and the Just case to AnnListLayout. Later commits will fine tune these against the actual parser layout. - - - - - 18fff7bf by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Use EpaLocation in EpVirtualBraces reword: EPA Use vocurly as basis for AnnListLayout For the existing cases that populate AnnList. This also shows up AnnList usages that can never capture layout. - - - - - 66eef6ef by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Use vocurly as basis for AnnListLayout For the existing cases that populate AnnList. This also shows up AnnList usages that can never capture layout. - - - - - e006c3cc by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: AnnList clean up patch for empty where clause - - - - - c49da845 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Add TTG fields to FamilyInfo This commit is a simple add, with unused extension fields. It lays the groundwork for using them for exact print annotations - - - - - 37a82a15 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 WIP annclassdecl - - - - - 275673e0 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Update AnnClsInstDecl to contain AnnList It was already separately tracking the '{', '}' and leading ';' values. This aligns it with layout-introducing parser productions ('vocurly'), so the layout processing can be handled uniformly - - - - - fdf60bb6 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Tidy up markAnnListA' It takes an action which can modify the AnnList, but this is never used. So remove it. - - - - - a1814bc6 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Use AnnList for GADT declarations - - - - - c16d3334 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Use AnnList in AnnClassDecl - - - - - 977d5d70 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 MOVE EPA: Plan for Fixing AnnList Layout Properly - - - - - 2b939090 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Make local binds located Use LHsLocalBinds instead of HsLocalBinds This reverses an earlier change, and brings processing of local binds into alignement with the exact printing principle that the LocatedA contents provide the location and extent of the enclosed item, together with any comments or context-specific trailing items like commas or semi colons. The internal TTG extension points only carry exact print annotations related to printing the item within its bounds. This change brings back the problem of EmptyLocalBinds, which by definition cannot have a location. These get a noSrcSpan location, which is ignored in the exact printing process. - - - - - 2335ce8f by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Use AnnList in HsMultiIf It introduces layout, capture it - - - - - d8659ea3 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Use AnnList in DecBrl - - - - - 41cfe430 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Replace AnnListLayout / AnnListBrackets with EpLayout - - - - - ceb37c77 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 WIP: setLayoutBoth inside markAnnListA Current problem is it is a global one-shot, and MG has one too Check: is it needed? if so, honouring EpLayout may be needed - - - - - 739934cb by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA some tests for layout. WIP - - - - - 962c7967 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 Exactprint layout scope plan. Do not commit - - - - - 5336604f by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: tidy up a bit. Combine somewhere else - - - - - bc5c1431 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Introduce LayoutFrame stacks in ExactPrint state - - - - - 34e2f42c by Alan Zimmerman at 2026-09-23T15:26:53+01:00 Align with ghc-exactprint - - - - - 727725f1 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Fix AnnList leading semis when layout When there is layout, anything printed triggers it, including leading semis. Add some test case examples too - - - - - 0c55ef4b by Alan Zimmerman at 2026-09-23T15:26:53+01:00 Exactprint: tidy up layout capturing - - - - - 8ea21bf4 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: add makeDelta test for Test20297 The original #20297 related to comment placement for exact printing after running ExactPrint.makeDelta on ParsedSource. Add an additional test that explicitly tests this. - - - - - 4e2a2823 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Make ValBinds LocatedA in HsLocalBindsLR If we have items with an AnnList Annotation, as part of another, which has different content, it must be LocatedA. This is a technical requirement due to the way comment allocation happens during the makeDelta processing. Comments are queued for printing, and as soon as any non-comment is to be printed, the pending comments before that position are printed, and in makeDelta processing these attached as preceding comments to the thing just printed. The means they end up captured inside the layout region of the AnnList item. So for foo = x where -- comment x = 3 the comment ends up as a preceding comment of `x = 3`, inside the layout, and prints as foo = x where -- comment x = 3 - - - - - c5a1b1c2 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Make IPBinds LocatedA - - - - - 266ba0c7 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Make ClsInstDecl decls LocatedA - - - - - 281fd5ef by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Make ClassDecls decls LocatedA - - - - - 485adbaa by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Make ClosedTypeFamily equations Located For FamilyDecl/ClosedTypeFamily - - - - - dad22bd7 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Make dd_cons located - - - - - a18f4dd4 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Make HsMultiIf options located - - - - - 5d41afbd by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Make DecBrl contents LocatedA - - - - - 89eaed44 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Located do statements - - - - - 84406448 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Print RecStmt located - - - - - 897da1a6 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: HsCmdDo Located - - - - - d5eb9015 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 Extend Test20297 for additional occurrences - - - - - f260acd6 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Tweak PatSynBind location for comments - - - - - 84528cc5 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: WIP, add test for where ;; ValBinds - - - - - a80d3263 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Make EpVirtualBraces noSpanAnchor if no contents Otherwise the vocurly is emitted at the start of the next item parsed Check: is this needed, or just a check for empty contents? - - - - - 9dd58d8e by Alan Zimmerman at 2026-09-23T15:26:53+01:00 WIP: turn of exactprint debug printing - - - - - cdcbfb30 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Remove CanUpdateAnchorOnly - - - - - 55d692b0 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 Plan update DO NOT COMMIT - - - - - 7ea8771f by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: First pass implementation of HsList, for ClassDecls Just as a straight list replacement to start with, no payload. This shows the scope and invasiveness of the initial change - - - - - ef05ddb4 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: HsList attempt WIP - - - - - c879ec1b by Alan Zimmerman at 2026-09-23T15:26:53+01:00 Enable ppr test for Haddock1. It currently fails - - - - - dfc8bb36 by Alan Zimmerman at 2026-09-23T15:26:53+01:00 WIP on removing NoEpAnn. Likely abandon - - - - - 58b8761a by Alan Zimmerman at 2026-09-23T15:26:53+01:00 EPA: Add an overview doc for exact printing - - - - - 8ebd722d by Simon Peyton Jones at 2026-09-23T15:26:53+01:00 Added an intro section - - - - - 120 changed files: - + ANNLIST-LAYOUT-PLAN.md - + ExactPrint.md - + LAYOUT-SCOPE-PLAN.md - + changelog.d/26610 - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main/Interactive.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Stats.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Expr.hs-boot - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.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/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Functor.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax.hs - compiler/Language/Haskell/Syntax/Basic.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Extension.hs - ghc/GHCi/UI.hs - rts/include/stg/Prim.h - rts/prim/bitrev.c - rts/prim/bswap.c - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - + testsuite/tests/ghci/prog-mhu008/Makefile - + testsuite/tests/ghci/prog-mhu008/a/M.hs - + testsuite/tests/ghci/prog-mhu008/all.T - + testsuite/tests/ghci/prog-mhu008/b/M.hs - + testsuite/tests/ghci/prog-mhu008/prog-mhu008.script - + testsuite/tests/ghci/prog-mhu008/prog-mhu008.stdout - + testsuite/tests/ghci/prog-mhu008/unitA - + testsuite/tests/ghci/prog-mhu008/unitB - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.hs - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/parser/should_compile/T15279.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20718b.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/perf/compiler/hard_hole_fits.stderr - + testsuite/tests/primops/should_run/T27299.hs - + testsuite/tests/primops/should_run/T27299.stdout - testsuite/tests/primops/should_run/all.T - testsuite/tests/printer/AnnotationNoListTuplePuns.stdout - + testsuite/tests/printer/Layout.hs - testsuite/tests/printer/Makefile - testsuite/tests/printer/Ppr003.hs - testsuite/tests/printer/T18791.stderr - + testsuite/tests/printer/Test20297.expected.hs - testsuite/tests/printer/Test20297.hs - testsuite/tests/printer/Test20297.stdout - + testsuite/tests/printer/Test20297MD.stdout - testsuite/tests/printer/Test24533.stdout - testsuite/tests/printer/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.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/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.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/816483fb4adca4e39fd61a74a2591e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/816483fb4adca4e39fd61a74a2591e… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/az/epa-tidy-locatedxxx-25] 3 commits: Change the C types of hs_{bitrev,bswap}{16,32} to match the Haskell types
by Alan Zimmerman (＠alanz) 23 Sep '26

23 Sep '26

Alan Zimmerman pushed to branch wip/az/epa-tidy-locatedxxx-25 at Glasgow Haskell Compiler / GHC Commits: 545fd4fb by ARATA Mizuki at 2026-09-22T15:03:24-04:00 Change the C types of hs_{bitrev,bswap}{16,32} to match the Haskell types bitReverse{16,32}# and byteSwap{16,32}# have the type Word# -> Word#, but their C correspondents took and returned StgWord{16,32}. The mismatch on bitReverse16# led to the problem reported in #27299. Although no similar issue is reported for bitReverse32# and byteSwap{16,32}#, it seemed wise to change them proactively. This commit fixes the mismatch by changing the C type. Fixes #27299 - - - - - bf17f289 by fendor at 2026-09-22T15:04:05-04:00 Don't lose instances from shadowed imported modules with the same name When we look for instances below the current module, we need to check the unit id as well when we check for whether the module is the current module, otherwise we ignore modules we import that have the same name as the import module. Adds regression test. - - - - - bd9b258a by Alan Zimmerman at 2026-09-23T15:23:41+01:00 EPA: Add specific layout field to AnnList Up to now AnnList has effectively served to represent lists of things having layout, regardless of whether they do or not. In Haskell, layout is optional in many places, as there is also an alternative syntax using braces and semi-colons, which is free-form. This commit introduces AnnListLayout, a data structure capturing this distinction. It is deliberately set up similarly to EpLayout, so that these two can be merged in time. The transition is done mechanically, where AnnListBraces is not used yet, the original Nothing case maps to AnnListNoLayout, and the Just case to AnnListLayout. Later commits will fine tune these against the actual parser layout. - - - - - 35 changed files: - + changelog.d/26610 - compiler/GHC/Driver/Env.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - rts/include/stg/Prim.h - rts/prim/bitrev.c - rts/prim/bswap.c - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - + testsuite/tests/ghci/prog-mhu008/Makefile - + testsuite/tests/ghci/prog-mhu008/a/M.hs - + testsuite/tests/ghci/prog-mhu008/all.T - + testsuite/tests/ghci/prog-mhu008/b/M.hs - + testsuite/tests/ghci/prog-mhu008/prog-mhu008.script - + testsuite/tests/ghci/prog-mhu008/prog-mhu008.stdout - + testsuite/tests/ghci/prog-mhu008/unitA - + testsuite/tests/ghci/prog-mhu008/unitB - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T15279.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20846.stderr - + testsuite/tests/primops/should_run/T27299.hs - + testsuite/tests/primops/should_run/T27299.stdout - testsuite/tests/primops/should_run/all.T - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7c93b79386360eb860155b65c293da… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7c93b79386360eb860155b65c293da… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/clc-proposal-442] 3 commits: Update expected error message in testcase T25180
by BinderDavid (＠BinderDavid) 23 Sep '26

23 Sep '26

BinderDavid pushed to branch wip/clc-proposal-442 at Glasgow Haskell Compiler / GHC Commits: 8801a723 by David Binder at 2026-09-23T13:42:21+01:00 Update expected error message in testcase T25180 The testcase T25180 checks for the error messages when the file is compiled with the options: '-fdefer-type-errors -fno-max-valid-hole-fits' - - - - - 240fa032 by David Binder at 2026-09-23T14:00:21+01:00 Fix expected output in testsuite of haddock - - - - - e2b8ee4b by David Binder at 2026-09-23T14:17:20+01:00 Add entry to changelog.d - - - - - 4 changed files: - + changelog.d/clc-442 - testsuite/tests/typecheck/should_compile/T25180.stderr - utils/haddock/html-test/ref/Bug923.html - utils/haddock/html-test/ref/Instances.html Changes: ===================================== changelog.d/clc-442 ===================================== @@ -0,0 +1,8 @@ +section: base +mrs: !16718 +synopsis: + Expose `data Unit` and `data TupleN` from `Data.Tuple` in `base` +description: + The data types `data Unit` and `data TupleN` (for N from 2 to 64) are now exported from + `Data.Tuple` in the `base` library instead of `Data.Tuple.Experimental` in `ghc-experimental`. + See `CLC proposal 442 <https://github.com/haskell/core-libraries-committee/issues/442>`_. ===================================== testsuite/tests/typecheck/should_compile/T25180.stderr ===================================== @@ -5,6 +5,9 @@ T25180.hs:12:8: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] Valid hole fits include tup0 :: () (bound at T25180.hs:12:1) () :: () (bound at <wired into compiler>) + () :: () + (imported from ‘Data.Tuple’ at T25180.hs:6:1-17 + (and originally defined in ‘GHC.Internal.Tuple’)) mempty :: forall a. Monoid a => a with mempty @() (imported from ‘Prelude’ @@ -60,6 +63,10 @@ T25180.hs:26:8: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] (,) :: forall a b. a -> b -> (a, b) with (,) @a @b (bound at <wired into compiler>) + (,) :: forall a b. a -> b -> (a, b) + with (,) @a @b + (imported from ‘Data.Tuple’ at T25180.hs:6:1-17 + (and originally defined in ‘GHC.Internal.Tuple’)) T25180.hs:33:8: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] • Found hole: _ :: a -> b -> c -> (a, b, c) @@ -75,6 +82,10 @@ T25180.hs:33:8: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] (,,) :: forall a b c. a -> b -> c -> (a, b, c) with (,,) @a @b @c (bound at <wired into compiler>) + (,,) :: forall a b c. a -> b -> c -> (a, b, c) + with (,,) @a @b @c + (imported from ‘Data.Tuple’ at T25180.hs:6:1-17 + (and originally defined in ‘GHC.Internal.Tuple’)) T25180.hs:38:11: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] • Found hole: _ :: (# #) ===================================== utils/haddock/html-test/ref/Bug923.html ===================================== @@ -76,7 +76,9 @@ >forall a. a -> <a href="#" title="Bug923" >T</a - > ('(,) a :: <a href="#" title="Data.Kind" + > ('<a href="#" title="Data.Tuple" + >(,)</a + > a :: <a href="#" title="Data.Kind" >Type</a > -> (<a href="#" title="Data.Kind" >Type</a @@ -126,7 +128,9 @@ >forall a. a -> <a href="#" title="Bug923" >T</a - > ('(,) a :: <a href="#" title="Data.Kind" + > ('<a href="#" title="Data.Tuple" + >(,)</a + > a :: <a href="#" title="Data.Kind" >Type</a > -> (<a href="#" title="Data.Kind" >Type</a @@ -156,7 +160,9 @@ >Eq</a > (<a href="#" title="Bug923" >T</a - > ('(,) a :: <a href="#" title="Data.Kind" + > ('<a href="#" title="Data.Tuple" + >(,)</a + > a :: <a href="#" title="Data.Kind" >Type</a > -> (<a href="#" title="Data.Kind" >Type</a @@ -188,7 +194,9 @@ >(==)</a > :: <a href="#" title="Bug923" >T</a - > ('(,) a :: <a href="#" title="Data.Kind" + > ('<a href="#" title="Data.Tuple" + >(,)</a + > a :: <a href="#" title="Data.Kind" >Type</a > -> (<a href="#" title="Data.Kind" >Type</a @@ -196,7 +204,9 @@ >Type</a >)) -> <a href="#" title="Bug923" >T</a - > ('(,) a :: <a href="#" title="Data.Kind" + > ('<a href="#" title="Data.Tuple" + >(,)</a + > a :: <a href="#" title="Data.Kind" >Type</a > -> (<a href="#" title="Data.Kind" >Type</a @@ -212,7 +222,9 @@ >(/=)</a > :: <a href="#" title="Bug923" >T</a - > ('(,) a :: <a href="#" title="Data.Kind" + > ('<a href="#" title="Data.Tuple" + >(,)</a + > a :: <a href="#" title="Data.Kind" >Type</a > -> (<a href="#" title="Data.Kind" >Type</a @@ -220,7 +232,9 @@ >Type</a >)) -> <a href="#" title="Bug923" >T</a - > ('(,) a :: <a href="#" title="Data.Kind" + > ('<a href="#" title="Data.Tuple" + >(,)</a + > a :: <a href="#" title="Data.Kind" >Type</a > -> (<a href="#" title="Data.Kind" >Type</a ===================================== utils/haddock/html-test/ref/Instances.html ===================================== @@ -450,7 +450,9 @@ >) => <a href="#" title="Instances" >Foo</a - > ((,) (f a)) (<a href="#" title="Data.Tuple" + >(,)</a + > (f a)) <a href="#" class="selflink" >#</a ></td @@ -560,7 +562,9 @@ > <a href="#" title="Instances" >Foo</a - > ((,,) a a) (<a href="#" title="Data.Tuple" + >(,,)</a + > a a) <a href="#" class="selflink" >#</a ></td @@ -1164,9 +1168,13 @@ > <a href="#" title="Instances" >Foo</a - > ((,,) a b) => <a href="#" title="Instances" + > (<a href="#" title="Data.Tuple" + >(,,)</a + > a b) => <a href="#" title="Instances" >Bar</a - > ((,,) a b) (a, b, a) (<a href="#" title="Data.Tuple" + >(,,)</a + > a b) (a, b, a) <a href="#" class="selflink" >#</a ></td View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0957bd7e5c7bb455716cd646725ab5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0957bd7e5c7bb455716cd646725ab5… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/apk/tag-strict-bot] Fix a few tag inference bugs.
by Andreas Klebinger (＠AndreasK) 23 Sep '26

23 Sep '26

Andreas Klebinger pushed to branch wip/apk/tag-strict-bot at Glasgow Haskell Compiler / GHC Commits: ec64d9d2 by Andreas Klebinger at 2026-09-23T12:10:43+00:00 Fix a few tag inference bugs. * Treat bottoming functions and nullary join points as functions. * When generating bytecode don't rely on imported tag sigs. Fixes #27831, #27841 and #27842. - - - - - 21 changed files: - + changelog.d/T27831-bottoming-strict-field - + changelog.d/T27842-bytecode-imported-tags - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/Stg/EnforceEpt/Rewrite.hs - compiler/GHC/Stg/EnforceEpt/Types.hs - + testsuite/tests/bytecode/T27842.hs - + testsuite/tests/bytecode/T27842.stdout - + testsuite/tests/bytecode/T27842A.hs - + testsuite/tests/bytecode/T27842N.hs - testsuite/tests/bytecode/all.T - testsuite/tests/simplStg/should_compile/all.T - + testsuite/tests/simplStg/should_compile/inferTags005.hs - + testsuite/tests/simplStg/should_compile/inferTags005.stderr - + testsuite/tests/simplStg/should_compile/inferTags006.hs - + testsuite/tests/simplStg/should_compile/inferTags006.stderr - + testsuite/tests/simplStg/should_run/InferTags007_A.hs - + testsuite/tests/simplStg/should_run/T27831.hs - + testsuite/tests/simplStg/should_run/T27831.stdout - testsuite/tests/simplStg/should_run/all.T - + testsuite/tests/simplStg/should_run/inferTags007.hs - + testsuite/tests/simplStg/should_run/inferTags007.stdout Changes: ===================================== changelog.d/T27831-bottoming-strict-field ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27831 +mrs: !16719 +synopsis: + Fix a segfault that could occur when a bottoming function was stored in a strict field. +description: + This was happening when a function that always diverges (e.g. ``\_ -> error "..."``) was stored in a strict field, and the constructor was pattern matched on + in "nearby" code where the structure of the constructor application was still visible to GHC. ===================================== changelog.d/T27842-bytecode-imported-tags ===================================== @@ -0,0 +1,6 @@ +section: bytecode +issues: #27842 +mrs: !16719 +synopsis: + Fix a segfault caused by reusing interface files generated with + ``-fbyte-code-and-object-code`` for interpreter sessions using ``-fprefer-byte-code``. ===================================== compiler/GHC/Stg/EnforceEpt.hs ===================================== @@ -334,9 +334,15 @@ a) Tags for let-bindings: b) When referencing ids from other modules the Cmm backend will try to put a proper tag on these references through various means. When doing analysis we usually predict these cases to improve precision of the analysis. - But to my knowledge the bytecode generator makes no such attempts so we must - not infer imported bindings as tagged. - This is handled in GHC.Stg.EnforceEpt.Types.lookupInfo + The bytecode generator gives fewer guarantees about what it tags. + So we simply assume it fails to tag binders, even in the cases where it does. + + This is handled in GHC.Stg.EnforceEpt.Types.argTagInfo + + Eventually we will want to update the Analysis and bco code gen to uphold and + take advantage of tag inference at least to some degree. But for now it's + not a perf benefit for interpreted code, and essentially only run to uphold + the "strict field invariant"/EPT Invariant described in EPT enforcement. -} @@ -359,7 +365,7 @@ enforceEpt ppr_opts !for_bytecode logger this_mod stg_binds = do -- Rewrite STG to uphold the strict field invariant us_t <- mkSplitUniqSupply StgTag - let rewritten_binds = {-# SCC "StgEptRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding] + let rewritten_binds = {-# SCC "StgEptRewrite" #-} rewriteTopBinds for_bytecode this_mod us_t stg_binds_w_tags :: [TgStgTopBinding] return (rewritten_binds,export_tag_info) @@ -414,12 +420,14 @@ inferTagExpr env (StgApp fun args) | isDeadEndAppSig (idDmdSig fun) (length args) = TagBottoming - | fun_arity == 0 -- Unknown arity => Thunk or unknown call + | not (isJoinId fun) -- zero arity join ids behave like functions. + , fun_arity == 0 -- Unknown arity => Thunk or unknown call = TagDunno -- Imported function with known return tag | Just (TagFun res_info) <- tagSigInfo (idInfo fun) , fun_arity == length args -- Saturated + , not (te_bytecode env) -- #27842 = res_info -- Local function with known return tag @@ -613,8 +621,8 @@ it safely any tag sig we like. So we give it TagBottoming, as it allows the combined tag sig of the case expression to be the combination of all non-bottoming branches. -NB: After the analysis is done we go back to treating bottoming functions as -untagged to ensure they are evaluated as expected in code like: +NB: We now distinguish functions from values. Allowing us to treat bottom functions +as tagged, while still doing the right thing for bottom values in code like: case bottom_id of { ...} ===================================== compiler/GHC/Stg/EnforceEpt/Rewrite.hs ===================================== @@ -13,7 +13,7 @@ import GHC.Builtin.PrimOps ( PrimOp(..) ) import GHC.Types.Basic ( CbvMark (..), isMarkedCbv , TopLevelFlag(..), isTopLevel ) import GHC.Types.Id -import GHC.Types.Name +import GHC.Types.Name ( nameIsLocalOrFrom ) import GHC.Types.Unique.Supply import GHC.Types.Unique.FM import GHC.Types.RepType @@ -22,10 +22,7 @@ import GHC.Unit.Types import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) -import GHC.Core.Type - -import GHC.StgToCmm.Types -import GHC.StgToCmm.Closure (importedIdLFInfo) +import GHC.Core.Type ( definitelyLiftedType ) import GHC.Stg.Utils import GHC.Stg.Syntax as StgSyn @@ -41,7 +38,7 @@ import GHC.Stg.EnforceEpt.Types import Control.Monad -newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) } +newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet, Bool) a) } deriving (Functor, Monad, Applicative) ------------------------------------------------------------ @@ -108,29 +105,34 @@ when building the free variable list. instance MonadUnique RM where getUniqueSupplyM = RM $ do - (m, us, mod,lcls) <- get + (m, us, mod,lcls,for_bytecode) <- get let (us1, us2) = splitUniqSupply us - (put) (m,us2,mod,lcls) + (put) (m,us2,mod,lcls,for_bytecode) return us1 getMap :: RM (UniqFM Id TagSig) -getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get) +getMap = RM $ ((\(fst,_,_,_,_) -> fst) <$> get) setMap :: (UniqFM Id TagSig) -> RM () setMap !m = RM $ do - (_,us,mod,lcls) <- get - put (m, us,mod,lcls) - -getMod :: RM Module -getMod = RM $ ( (\(_,_,thrd,_) -> thrd) <$> get) + (_,us,mod,lcls,for_bytecode) <- get + put (m, us,mod,lcls,for_bytecode) getFVs :: RM IdSet -getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get) +getFVs = RM $ ((\(_,_,_,lcls,_) -> lcls) <$> get) setFVs :: IdSet -> RM () setFVs !fvs = RM $ do - (tag_map,us,mod,_lcls) <- get - put (tag_map, us,mod,fvs) + (tag_map,us,mod,_lcls,for_bytecode) <- get + put (tag_map, us,mod,fvs,for_bytecode) + +getMod :: RM Module +getMod = RM $ ( (\(_,_,c,_,_) -> c) <$> get) + +-- | Are we generating bytecode? Must agree with the flag the analysis ran +-- with, so both sides make the same tagging decisions. +getForBytecode :: RM Bool +getForBytecode = RM $ ((\(_,_,_,_,for_bytecode) -> for_bytecode) <$> get) -- Rewrite the RHS(s) while making the id and it's sig available -- to determine if things are tagged/need to be captured as FV. @@ -238,51 +240,26 @@ indicates a bug in the tag inference implementation. For this reason we assert that we are running in interactive mode if a lookup fails. -} isTagged :: Id -> RM Bool -isTagged v - -- See Note [Bottom functions are TagBottoming] - | isDeadEndId v = pure False - | otherwise = do +isTagged v = do + for_bytecode <- getForBytecode this_mod <- getMod - -- See Note [Tag inference for interactive contexts] - let lookupDefault v = assertPpr (isInteractiveModule this_mod) - (text "unknown Id:" <> ppr this_mod <+> ppr v) - (TagVal TagDunno) - case nameIsLocalOrFrom this_mod (idName v) of - True - | definitelyUnliftedType (idType v) - -- NB: v might be the Id of a representation-polymorphic join point, - -- so we shouldn't use isUnliftedType here. See T22212. - -> return True - | otherwise -> do -- Local binding - !s <- getMap - let !sig = lookupWithDefaultUFM s (lookupDefault v) v - return $ case sig of - TagFun _ -> True -- function closure is tagged - TagVal TagDunno -> False - TagVal TagEPT -> True - TagVal TagBottoming -> True - TagVal (TagTuple _) -> True -- Consider unboxed tuples tagged. - -- Imported - False -> return $! - -- Determine whether it is tagged from the LFInfo of the imported id. - -- See Note [The LFInfo of Imported Ids] - case importedIdLFInfo v of - -- Function, applied not entered. - LFReEntrant {} - -> True - -- Thunks need to be entered. - LFThunk {} - -> False - -- LFCon means we already know the tag, and it's tagged. - LFCon {} - -> True - LFUnknown {} - -> False - LFUnlifted {} -- Unboxed, tagging irrelevant - -> True - LFLetNoEscape {} - -- Shouldn't be possible. I don't think we can export letNoEscapes - -> True + s <- getMap + let get_env_sig = lookupUFM s + massertPpr + -- Assert the env is complete for local lifted binders, which means either + -- - The binder is present in the env + -- - The binder is not a local lifted binder or comes from a ghci context + (isJust (get_env_sig v) + -- See Note [Tag inference for interactive contexts] + || isInteractiveModule this_mod + || not (nameIsLocalOrFrom this_mod (idName v)) + || not (definitelyLiftedType (idType v))) + (text "unknown Id:" <> ppr this_mod <+> ppr v) + -- TODO: We could refactor the whole pass such that we also set id_tagSig + -- for every imported id. But this likely comes with a heavy allocation + -- overhead so for now we just ensure to use the same logic across analysis + -- and rewriter. + pure $! isTaggedInfo $ argTagInfo for_bytecode (get_env_sig v) (StgVarArg v) isArgTagged :: StgArg -> RM Bool @@ -299,11 +276,12 @@ mkLocalArgId id = do --------------------------- -rewriteTopBinds :: Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding] -rewriteTopBinds mod us binds = +rewriteTopBinds :: Bool -- ^ Generating bytecode? + -> Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding] +rewriteTopBinds for_bytecode mod us binds = let doBinds = mapM rewriteTop binds - in evalState (unRM doBinds) (mempty, us, mod, mempty) + in evalState (unRM doBinds) (mempty, us, mod, mempty, for_bytecode) rewriteTop :: InferStgTopBinding -> RM TgStgTopBinding rewriteTop (StgTopStringLit v s) = return $! (StgTopStringLit v s) ===================================== compiler/GHC/Stg/EnforceEpt/Types.hs ===================================== @@ -12,7 +12,7 @@ where import GHC.Prelude import GHC.Core.DataCon -import GHC.Core.Type (isUnliftedType) +import GHC.Core.Type (isUnliftedType, definitelyUnliftedType) import GHC.Types.Id import GHC.Stg.Syntax import GHC.Stg.EnforceEpt.TagSig as TagSig @@ -22,6 +22,7 @@ import GHC.Utils.Misc( zipWithEqual ) import GHC.Utils.Panic import GHC.StgToCmm.Types +import GHC.StgToCmm.Closure (importedIdLFInfo) {- ********************************************************************* * * @@ -97,31 +98,37 @@ lookupReturnInfo env fun = case lookupVarEnv (te_env env) fun of Just (TagVal _) -> Nothing Nothing -> Nothing --- | Look up a value-level tag for an argument: either from the env (where --- a function-typed argument flattens to TagEPT — its closure is tagged) --- or derived from information on the variable itself. -lookupInfo :: TagEnv p -> StgArg -> TagInfo -lookupInfo env (StgVarArg var) +{-# INLINE argTagInfo #-} -- Specialize for the call site. +-- | Look up a value-level tag. +-- +-- If we can do so faster avoid inspecting the env and compute the info from the Id. +-- If we can't check the provided env value or fall back to safe defaults. +argTagInfo :: Bool -> (Maybe TagSig) -> StgArg -> TagInfo +argTagInfo _for_bytecode _env_sig (StgLitArg{}) = TagEPT +argTagInfo for_bytecode env_sig (StgVarArg var) -- Nullary data constructors like True, False | Just dc <- isDataConWorkId_maybe var , isNullaryRepDataCon dc , not for_bytecode = TagEPT - | isUnliftedType (idType var) + -- NB: v might be the Id of a representation-polymorphic join point, + -- so we shouldn't use isUnliftedType here. See T22212. + | definitelyUnliftedType (idType var) = TagEPT -- Variables in the environment. A function binding flattens to TagEPT -- since a function closure pointer is properly tagged; its return info -- is not relevant when the function is used as a value. - | Just sig <- lookupVarEnv (te_env env) var + | Just sig <- env_sig = case sig of TagVal info -> info TagFun _ -> TagEPT - | Just lf_info <- idLFInfo_maybe var - , not for_bytecode - = case lf_info of + | lf_info <- importedIdLFInfo var -- will make up LFInfo if not present. + = if for_bytecode then TagDunno + else + case lf_info of -- Function, tagged (with arity) LFReEntrant {} -> TagEPT @@ -138,13 +145,14 @@ lookupInfo env (StgVarArg var) -- Shouldn't be possible. I don't think we can export letNoEscapes LFLetNoEscape {} -> panic "LFLetNoEscape exported" - | otherwise - = TagDunno - where - for_bytecode = te_bytecode env - -lookupInfo _ (StgLitArg {}) - = TagEPT +-- | Look up a value-level tag for an argument: either from the env (where +-- a function-typed argument flattens to TagEPT — its closure is tagged) +-- or derived from information on the variable itself. +lookupInfo :: TagEnv p -> StgArg -> TagInfo +lookupInfo env arg@(StgVarArg var) = + let env_sig = (lookupVarEnv (te_env env) var) + in argTagInfo (te_bytecode env) env_sig arg +lookupInfo _env (StgLitArg{}) = TagEPT isDunnoSig :: TagSig -> Bool isDunnoSig (TagVal TagDunno) = True ===================================== testsuite/tests/bytecode/T27842.hs ===================================== @@ -0,0 +1,42 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fno-worker-wrapper -fno-cpr-anal #-} +-- Regression test for #27842. +-- +-- The basic rundown is this: +-- We produce one interface file, however we store information dependent on the +-- code generation method in the interface file. +-- +-- We happen to pick the native code information to store in the interface file. +-- +-- When we compile a module M this way, and then generate byte code for code +-- depending on M based on M.hi we will assume certain exported definitions are EPT +-- tagged, despite the interpreter doing no such thing. +-- +-- This then led to crashes in the interpreter. +-- +-- We test three kinds of imported definitions: +-- * mk uses fun, a function whose TagSig says its result is tagged. +-- * bar uses just_con, a value whose LFInfo says it is a constructor. +-- * baz uses gt_con, the same for a nullary constructor. +module Main where + +import T27842A (fun, just_con, gt_con) +import T27842N (S(..), use_S, M(..), use_M, N(..), use_N) + +mk :: Int -> S +mk x = case fun x of (# xs, _ #) -> S xs +{-# NOINLINE mk #-} + +bar :: M +bar = M just_con +{-# NOINLINE bar #-} + +baz :: N +baz = N gt_con +{-# NOINLINE baz #-} + +main :: IO () +main = do + print (use_S (mk 42)) + print (use_M bar) + print (use_N baz) ===================================== testsuite/tests/bytecode/T27842.stdout ===================================== @@ -0,0 +1,3 @@ +42 +42 +3 ===================================== testsuite/tests/bytecode/T27842A.hs ===================================== @@ -0,0 +1,19 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fno-worker-wrapper -fno-cpr-anal #-} +module T27842A (fun, just_con, gt_con) where + +-- The native EPT run gives fun the TagSig TagFun[TagTuple[TagEPT, TagDunno]]: +fun :: Int -> (# [Int], Int #) +fun x = let xs = x : xs in (# xs, x #) +{-# NOINLINE fun #-} + +-- In native code a static constructor, in bytecode an unevaluated closure. +just_con :: Maybe Int +just_con = Just 42 +{-# NOINLINE just_con #-} + +-- The same for a nullary constructor. Without its pointer tag, the object code +-- in T27842N would take the LT alternative, so GT shows the difference. +gt_con :: Ordering +gt_con = GT +{-# NOINLINE gt_con #-} ===================================== testsuite/tests/bytecode/T27842N.hs ===================================== @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -fno-byte-code-and-object-code #-} +-- We compile this module as native code, depending on A's interface file. +-- A itself is loaded into GHCi, despite it's interface file being generated based +-- on native code generation. +module T27842N (S(..), use_S, M(..), use_M, N(..), use_N) where + +data S = S ![Int] + +-- We take apart the strict constructor value and branch on the value in its field. +-- If the field content is not EPT this causes undefined behaviour. + +use_S :: S -> Int +use_S (S xs) = case xs of { (y:_) -> y; [] -> -1 } +{-# NOINLINE use_S #-} + +data M = M !(Maybe Int) + +use_M :: M -> Int +use_M (M m) = case m of { Just x -> x; Nothing -> -1 } +{-# NOINLINE use_M #-} + +data N = N !Ordering + +use_N :: N -> Int +use_N (N o) = case o of { LT -> 1; EQ -> 2; GT -> 3 } +{-# NOINLINE use_N #-} ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -17,3 +17,12 @@ test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script']) test('T27001', [extra_files(['T27001.hs']), req_interp], run_command, ['{compiler} -e main -O -fno-unoptimized-core-for-interpreter T27001.hs']) + +# Bytecode must not trust tag information from imported interfaces, which +# comes from native code (#27842): neither the TagSig of an imported function +# nor the LFInfo of an imported value (with and without constructor fields). +test('T27842', [extra_files(['T27842A.hs', 'T27842N.hs']), req_interp], + run_command, + ['{compiler} -e main -O -fno-unoptimized-core-for-interpreter ' + '-fobject-code -fbyte-code-and-object-code -fwrite-byte-code -fprefer-byte-code ' + 'T27842.hs']) ===================================== testsuite/tests/simplStg/should_compile/all.T ===================================== @@ -25,5 +25,17 @@ test('inferTags003', [ only_ways(['optasm']), ], compile, ['-ddump-cmm -dno-typeable-binds -O']) test('inferTags004', normal, compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques']) test('T27005b', normal, compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques']) +# Both f and the join point j should have a signature TagTuple[TagEPT, TagEPT] +test('inferTags005', + grep_errmsg(r'(TagTuple\[TagEPT, TagEPT\])', [1]), + compile, + ['-O -fno-worker-wrapper -fno-cpr-anal -ddump-stg-tags ' + '-dno-typeable-binds -dsuppress-uniques']) +# The function needs to have a signature TagTuple[TagEPT, TagEPT] +test('inferTags006', + grep_errmsg(r'(TagTuple\[TagEPT, TagEPT\])', [1]), + compile, + ['-O -fno-worker-wrapper -fno-cpr-anal -fno-full-laziness -ddump-stg-tags ' + '-dno-typeable-binds -dsuppress-uniques']) test('T24806', grep_errmsg('^\\(T24806\\.\\$wgo'), compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques']) ===================================== testsuite/tests/simplStg/should_compile/inferTags005.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE UnboxedTuples #-} +module EnforceEpt005 where + +-- If we have +-- f x y = +-- join j = +-- <rhs> -- <TagTuple[TagEPT, TagEPT]]> +-- in case x of +-- 1 -> j +-- 2 -> j +-- _ -> +-- <something> -- <TagTuple[TagEPT, TagEPT]]> + +-- Consider the case where rhs and something both represent a tag value of <TagTuple[TagEPT, TagEPT]]> +-- In this case we want `f` to also give rise to TagFun [TagTuple[TagEPT, TagEPT]]] + +-- To achieve this we have to recognize j as a zero-arity function equivalent +-- which is what this test checks. + +-- The payoff is in `g` `r` is then known to be tagged, so `S r` needs no eval. +-- Only an unboxed tuple result exposes this. + +-- We disable worker/wrapper and CPR so `f` matches more closely the tests source. + +data T = A Int Int Int Int Int Int | B + +f :: Int -> Int -> (# T, T #) +f x y = case x of + 0 -> j + 1 -> j + _ -> (# B, B #) + where + j = (# A (y+1) (y*2) (y-3) (y*y) (y+x) (y*x), B #) +{-# NOINLINE f #-} + +data S = S !T + +g :: Int -> Int -> S +g x y = case f x y of (# r, _ #) -> S r ===================================== testsuite/tests/simplStg/should_compile/inferTags005.stderr ===================================== @@ -0,0 +1,2 @@ +TagTuple[TagEPT, TagEPT] +TagTuple[TagEPT, TagEPT] ===================================== testsuite/tests/simplStg/should_compile/inferTags006.hs ===================================== @@ -0,0 +1,31 @@ +{-# LANGUAGE UnboxedTuples #-} +module EnforceEpt006 where + +-- If we have +-- f x y = +-- join j = +-- <rhs> -- TagBottoming +-- in case x of +-- 1 -> j +-- 2 -> j +-- _ -> +-- <something> -- <TagTuple[TagEPT, TagEPT]]> + +-- Similar to inferTage005 we want to give `f` the signature: TagFun <TagTuple[TagEPT, TagEPT]]> +-- This requires us to give `j` a `TagFun[TagBottoming]` signature, which is safe because +-- either its execution will diverge, or the resulting tuple *will* have two +-- tagged values. + +data T = A Int Int Int Int Int Int | B + +f :: Int -> Int -> (# T, T #) +-- This case-of-case is just here to be optimized into a nullary join point. +f x y = case (case x of { 0 -> False; 1 -> False; _ -> True }) of + False -> error ("f: bad input " ++ show x ++ " " ++ show y ++ " " ++ show (x*y)) + True -> (# A (y+1) (y*2) (y-3) (y*y) (y+x) (y*x), B #) +{-# NOINLINE f #-} + +data S = S !T + +g :: Int -> Int -> S +g x y = case f x y of (# r, _ #) -> S r ===================================== testsuite/tests/simplStg/should_compile/inferTags006.stderr ===================================== @@ -0,0 +1 @@ +TagTuple[TagEPT, TagEPT] ===================================== testsuite/tests/simplStg/should_run/InferTags007_A.hs ===================================== @@ -0,0 +1,20 @@ +-- We suppress arity and LfInfo with the option. +{-# OPTIONS_GHC -fomit-interface-pragmas #-} +module InferTags007_A (fun, caf, bot, con) where + +fun :: Int -> Int +fun x = x + 1 +{-# NOINLINE fun #-} + +-- A CAF/thunk +caf :: [Int] +caf = map (* 2) [1 .. 10] +{-# NOINLINE caf #-} + +bot :: Int -> Int +bot _ = error "bot called" +{-# NOINLINE bot #-} + +con :: Maybe Int +con = Just 42 +{-# NOINLINE con #-} ===================================== testsuite/tests/simplStg/should_run/T27831.hs ===================================== @@ -0,0 +1,35 @@ +-- Regression test for #27831: a bottoming function stored in a strict +-- constructor field. +-- +-- Different parts of the tag inference machinery didn't agree on weither or not +-- a bottoming function should be treated as a EPT value, leading to a segfault. +module Main (main) where + +import Control.Exception +import GHC.Exts.Heap (GenClosure(..), getClosureData) +import System.Exit + +data T = MkT Int !(Int -> Int) + +t :: T +t = MkT 1 (\_ -> error "T27831") +{-# NOINLINE t #-} + +f :: () -> T +f _ = t +{-# OPAQUE f #-} + +main :: IO () +main = do + c <- getClosureData t + case c of + ThunkClosure{} -> putStrLn "FAIL: ThunkClosure" >> exitFailure + APClosure{} -> putStrLn "FAIL: APClosure" >> exitFailure + _ -> putStrLn "OK: not a thunk" + + case f () of MkT n _ -> print n + + r <- try (evaluate (case t of MkT _ g -> g 1)) + case r of + Left (ErrorCall msg) -> putStrLn ("OK: " ++ msg) + Right v -> putStrLn ("FAIL: got " ++ show v) >> exitFailure ===================================== testsuite/tests/simplStg/should_run/T27831.stdout ===================================== @@ -0,0 +1,3 @@ +OK: not a thunk +1 +OK: T27831 ===================================== testsuite/tests/simplStg/should_run/all.T ===================================== @@ -3,13 +3,15 @@ # extra run flags # expected process return value, if not zero -# Only compile with optimisation +# Only run optimised code, native and interpreted: +# We now generate bytecode from STG so we should test native and bytecode. def f( name, opts ): - opts.only_ways = ['optasm'] + opts.only_ways = ['optasm', 'ghci-opt'] setTestOpts(f) -test('T9291', normal, compile_and_run, ['']) +# Breakpoint ticks would break CSE which this tests. +test('T9291', [omit_ways(['ghci']), extra_hc_opts('-fno-break-points')], compile_and_run, ['']) test('T13536', normal, compile_and_run, ['']) test('T13536a', @@ -20,6 +22,15 @@ test('T13536a', test('inferTags001', normal, multimod_compile_and_run, ['inferTags001', 'inferTags001_a']) test('T22042', [extra_files(['T22042a.hs']),only_ways('normal'),unless(have_dynamic(), skip)], makefile_test, ['T22042']) -test('T23783', normal, multimod_compile_and_run, ['T23783', '-O -v0']) -test('unpack_enum', normal, compile_and_run, ['']) -test('T27005a', normal, compile_and_run, ['']) + +# Depends on tag inference being similarly effective for bytecode which it is not yet. +test('T23783', omit_ghci, multimod_compile_and_run, ['T23783', '-O -v0']) + +# Requires UNPACK which needs -O +test('unpack_enum', omit_ways(['ghci']), compile_and_run, ['']) + +# Tests that tag inference optimizes well, which is not the case for bytecode or +# when we insert profiling ticks. +test('T27005a', omit_ways(ghci_ways + prof_ways), compile_and_run, ['']) +test('T27831', omit_ways(ghci_ways + prof_ways), compile_and_run, ['']) +test('inferTags007', [extra_files(['InferTags007_A.hs'])], multimod_compile_and_run, ['inferTags007', '-O -v0']) ===================================== testsuite/tests/simplStg/should_run/inferTags007.hs ===================================== @@ -0,0 +1,109 @@ +{-# LANGUAGE MagicHash #-} +-- This test sanity checks the tag info we generate for imported binders which +-- have no real info in the .hi file. +-- +-- This is important to avoid running into cases where we optimistically +-- generated better information based on things like type than the +-- compiled code actually provided. For example GHCi doesn't ensure tagging +-- of constructors. +module Main (main) where + +import Control.Exception +import Control.Monad +import GHC.Exts (Addr#) +import GHC.Exts.Heap (GenClosure(..), getClosureData) +import GHC.Internal.Control.Exception.Base (patError) +import System.Exit + +import qualified InferTags007_A as A + +data S a = S !a + +data P = MkP !(Addr# -> Int) + +-- Put the imported values into a strict field of a top level Con +con_top_fun :: S (Int -> Int) +con_top_fun = S A.fun +{-# NOINLINE con_top_fun #-} + +con_top_caf :: S [Int] +con_top_caf = S A.caf +{-# NOINLINE con_top_caf #-} + +con_top_bot :: S (Int -> Int) +con_top_bot = S A.bot +{-# NOINLINE con_top_bot #-} + +con_top_con :: S (Maybe Int) +con_top_con = S A.con +{-# NOINLINE con_top_con #-} + +con_top_pat :: P +con_top_pat = MkP patError +{-# NOINLINE con_top_pat #-} + +-- Put the imported values into a strict field of a Con inside a rhs +expr_fun :: () -> S (Int -> Int) +expr_fun _ = S A.fun +{-# OPAQUE expr_fun #-} + +expr_caf :: () -> S [Int] +expr_caf _ = S A.caf +{-# OPAQUE expr_caf #-} + +expr_bot :: () -> S (Int -> Int) +expr_bot _ = S A.bot +{-# OPAQUE expr_bot #-} + +expr_con :: () -> S (Maybe Int) +expr_con _ = S A.con +{-# OPAQUE expr_con #-} + +-- Actually use the field. +use_S_head :: S [Int] -> Int +use_S_head (S xs) = case xs of { (y:_) -> y; [] -> -1 } +{-# NOINLINE use_S_head #-} + +use_S_fromJust :: S (Maybe Int) -> Int +use_S_fromJust (S m) = case m of { Just x -> x; Nothing -> -1 } +{-# NOINLINE use_S_fromJust #-} + +use_S_apply :: S (Int -> Int) -> Int +use_S_apply (S f) = f 1 +{-# NOINLINE use_S_apply #-} + +checkNotThunk :: String -> a -> IO () +checkNotThunk name x = do + c <- getClosureData x + case c of + ThunkClosure{} -> putStrLn ("FAIL: " ++ name ++ " is a thunk") >> exitFailure + APClosure{} -> putStrLn ("FAIL: " ++ name ++ " is an AP") >> exitFailure + _ -> pure () + +-- Pattern matching binds the field itself, so no selector thunk is involved. +checkField :: String -> S a -> IO () +checkField name (S x) = checkNotThunk name x +{-# NOINLINE checkField #-} + +main :: IO () +main = do + -- Check if the pointer in the strict field is a thunk. + checkField "con_top_caf" con_top_caf + checkField "con_top_fun" con_top_fun + checkField "con_top_bot" con_top_bot + checkField "con_top_con" con_top_con + case con_top_pat of MkP f -> checkNotThunk "con_top_pat" f + checkField "expr_caf" (expr_caf ()) + checkField "expr_fun" (expr_fun ()) + checkField "expr_bot" (expr_bot ()) + checkField "expr_con" (expr_con ()) + + -- Actually execute a case on the contents of the field. + print (use_S_head con_top_caf, use_S_head (expr_caf ())) + print (use_S_fromJust con_top_con, use_S_fromJust (expr_con ())) + print (use_S_apply con_top_fun, use_S_apply (expr_fun ())) + forM_ [con_top_bot, expr_bot ()] $ \s -> do + r <- try (evaluate (use_S_apply s)) + case r of + Left (ErrorCall msg) -> putStrLn ("OK: " ++ msg) + Right v -> putStrLn ("FAIL: got " ++ show v) >> exitFailure ===================================== testsuite/tests/simplStg/should_run/inferTags007.stdout ===================================== @@ -0,0 +1,5 @@ +(2,2) +(42,42) +(2,2) +OK: bot called +OK: bot called View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec64d9d27632dfc833786cc6f58e41e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec64d9d27632dfc833786cc6f58e41e… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/apk/tag-strict-bot] Fix a few tag inference bugs.
by Andreas Klebinger (＠AndreasK) 23 Sep '26

23 Sep '26

Andreas Klebinger pushed to branch wip/apk/tag-strict-bot at Glasgow Haskell Compiler / GHC Commits: 8a51f7e6 by Andreas Klebinger at 2026-09-23T12:01:20+00:00 Fix a few tag inference bugs. * Treat bottoming functions and nullary join points as functions. * When generating bytecode don't rely on imported tag sigs. Fixes #27831, #27841 and #27842. - - - - - 21 changed files: - + changelog.d/T27831-bottoming-strict-field - + changelog.d/T27842-bytecode-imported-tags - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/Stg/EnforceEpt/Rewrite.hs - compiler/GHC/Stg/EnforceEpt/Types.hs - + testsuite/tests/bytecode/T27842.hs - + testsuite/tests/bytecode/T27842.stdout - + testsuite/tests/bytecode/T27842A.hs - + testsuite/tests/bytecode/T27842N.hs - testsuite/tests/bytecode/all.T - testsuite/tests/simplStg/should_compile/all.T - + testsuite/tests/simplStg/should_compile/inferTags005.hs - + testsuite/tests/simplStg/should_compile/inferTags005.stderr - + testsuite/tests/simplStg/should_compile/inferTags006.hs - + testsuite/tests/simplStg/should_compile/inferTags006.stderr - + testsuite/tests/simplStg/should_run/InferTags007_A.hs - + testsuite/tests/simplStg/should_run/T27831.hs - + testsuite/tests/simplStg/should_run/T27831.stdout - testsuite/tests/simplStg/should_run/all.T - + testsuite/tests/simplStg/should_run/inferTags007.hs - + testsuite/tests/simplStg/should_run/inferTags007.stdout Changes: ===================================== changelog.d/T27831-bottoming-strict-field ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27831 +mrs: !TODO +synopsis: + Fix a segfault that could occur when a bottoming function was stored in a strict field. +description: + This was happening when a function that always diverges (e.g. ``\_ -> error "..."``) was stored in a strict field, and the constructor was pattern matched on + in "nearby" code where the structure of the constructor application was still visible to GHC. ===================================== changelog.d/T27842-bytecode-imported-tags ===================================== @@ -0,0 +1,6 @@ +section: bytecode +issues: #27842 +mrs: !TODO +synopsis: + Fix a segfault caused by reusing interface files generated with + ``-fbyte-code-and-object-code`` for interpreter sessions using ``-fprefer-byte-code``. \ No newline at end of file ===================================== compiler/GHC/Stg/EnforceEpt.hs ===================================== @@ -334,9 +334,15 @@ a) Tags for let-bindings: b) When referencing ids from other modules the Cmm backend will try to put a proper tag on these references through various means. When doing analysis we usually predict these cases to improve precision of the analysis. - But to my knowledge the bytecode generator makes no such attempts so we must - not infer imported bindings as tagged. - This is handled in GHC.Stg.EnforceEpt.Types.lookupInfo + The bytecode generator gives fewer guarantees about what it tags. + So we simply assume it fails to tag binders, even in the cases where it does. + + This is handled in GHC.Stg.EnforceEpt.Types.argTagInfo + + Eventually we will want to update the Analysis and bco code gen to uphold and + take advantage of tag inference at least to some degree. But for now it's + not a perf benefit for interpreted code, and essentially only run to uphold + the "strict field invariant"/EPT Invariant described in EPT enforcement. -} @@ -359,7 +365,7 @@ enforceEpt ppr_opts !for_bytecode logger this_mod stg_binds = do -- Rewrite STG to uphold the strict field invariant us_t <- mkSplitUniqSupply StgTag - let rewritten_binds = {-# SCC "StgEptRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding] + let rewritten_binds = {-# SCC "StgEptRewrite" #-} rewriteTopBinds for_bytecode this_mod us_t stg_binds_w_tags :: [TgStgTopBinding] return (rewritten_binds,export_tag_info) @@ -414,12 +420,14 @@ inferTagExpr env (StgApp fun args) | isDeadEndAppSig (idDmdSig fun) (length args) = TagBottoming - | fun_arity == 0 -- Unknown arity => Thunk or unknown call + | not (isJoinId fun) -- zero arity join ids behave like functions. + , fun_arity == 0 -- Unknown arity => Thunk or unknown call = TagDunno -- Imported function with known return tag | Just (TagFun res_info) <- tagSigInfo (idInfo fun) , fun_arity == length args -- Saturated + , not (te_bytecode env) -- #27842 = res_info -- Local function with known return tag @@ -613,8 +621,8 @@ it safely any tag sig we like. So we give it TagBottoming, as it allows the combined tag sig of the case expression to be the combination of all non-bottoming branches. -NB: After the analysis is done we go back to treating bottoming functions as -untagged to ensure they are evaluated as expected in code like: +NB: We now distinguish functions from values. Allowing us to treat bottom functions +as tagged, while still doing the right thing for bottom values in code like: case bottom_id of { ...} ===================================== compiler/GHC/Stg/EnforceEpt/Rewrite.hs ===================================== @@ -13,7 +13,7 @@ import GHC.Builtin.PrimOps ( PrimOp(..) ) import GHC.Types.Basic ( CbvMark (..), isMarkedCbv , TopLevelFlag(..), isTopLevel ) import GHC.Types.Id -import GHC.Types.Name +import GHC.Types.Name ( nameIsLocalOrFrom ) import GHC.Types.Unique.Supply import GHC.Types.Unique.FM import GHC.Types.RepType @@ -22,10 +22,7 @@ import GHC.Unit.Types import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) -import GHC.Core.Type - -import GHC.StgToCmm.Types -import GHC.StgToCmm.Closure (importedIdLFInfo) +import GHC.Core.Type ( definitelyLiftedType ) import GHC.Stg.Utils import GHC.Stg.Syntax as StgSyn @@ -41,7 +38,7 @@ import GHC.Stg.EnforceEpt.Types import Control.Monad -newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) } +newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet, Bool) a) } deriving (Functor, Monad, Applicative) ------------------------------------------------------------ @@ -108,29 +105,34 @@ when building the free variable list. instance MonadUnique RM where getUniqueSupplyM = RM $ do - (m, us, mod,lcls) <- get + (m, us, mod,lcls,for_bytecode) <- get let (us1, us2) = splitUniqSupply us - (put) (m,us2,mod,lcls) + (put) (m,us2,mod,lcls,for_bytecode) return us1 getMap :: RM (UniqFM Id TagSig) -getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get) +getMap = RM $ ((\(fst,_,_,_,_) -> fst) <$> get) setMap :: (UniqFM Id TagSig) -> RM () setMap !m = RM $ do - (_,us,mod,lcls) <- get - put (m, us,mod,lcls) - -getMod :: RM Module -getMod = RM $ ( (\(_,_,thrd,_) -> thrd) <$> get) + (_,us,mod,lcls,for_bytecode) <- get + put (m, us,mod,lcls,for_bytecode) getFVs :: RM IdSet -getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get) +getFVs = RM $ ((\(_,_,_,lcls,_) -> lcls) <$> get) setFVs :: IdSet -> RM () setFVs !fvs = RM $ do - (tag_map,us,mod,_lcls) <- get - put (tag_map, us,mod,fvs) + (tag_map,us,mod,_lcls,for_bytecode) <- get + put (tag_map, us,mod,fvs,for_bytecode) + +getMod :: RM Module +getMod = RM $ ( (\(_,_,c,_,_) -> c) <$> get) + +-- | Are we generating bytecode? Must agree with the flag the analysis ran +-- with, so both sides make the same tagging decisions. +getForBytecode :: RM Bool +getForBytecode = RM $ ((\(_,_,_,_,for_bytecode) -> for_bytecode) <$> get) -- Rewrite the RHS(s) while making the id and it's sig available -- to determine if things are tagged/need to be captured as FV. @@ -238,51 +240,26 @@ indicates a bug in the tag inference implementation. For this reason we assert that we are running in interactive mode if a lookup fails. -} isTagged :: Id -> RM Bool -isTagged v - -- See Note [Bottom functions are TagBottoming] - | isDeadEndId v = pure False - | otherwise = do +isTagged v = do + for_bytecode <- getForBytecode this_mod <- getMod - -- See Note [Tag inference for interactive contexts] - let lookupDefault v = assertPpr (isInteractiveModule this_mod) - (text "unknown Id:" <> ppr this_mod <+> ppr v) - (TagVal TagDunno) - case nameIsLocalOrFrom this_mod (idName v) of - True - | definitelyUnliftedType (idType v) - -- NB: v might be the Id of a representation-polymorphic join point, - -- so we shouldn't use isUnliftedType here. See T22212. - -> return True - | otherwise -> do -- Local binding - !s <- getMap - let !sig = lookupWithDefaultUFM s (lookupDefault v) v - return $ case sig of - TagFun _ -> True -- function closure is tagged - TagVal TagDunno -> False - TagVal TagEPT -> True - TagVal TagBottoming -> True - TagVal (TagTuple _) -> True -- Consider unboxed tuples tagged. - -- Imported - False -> return $! - -- Determine whether it is tagged from the LFInfo of the imported id. - -- See Note [The LFInfo of Imported Ids] - case importedIdLFInfo v of - -- Function, applied not entered. - LFReEntrant {} - -> True - -- Thunks need to be entered. - LFThunk {} - -> False - -- LFCon means we already know the tag, and it's tagged. - LFCon {} - -> True - LFUnknown {} - -> False - LFUnlifted {} -- Unboxed, tagging irrelevant - -> True - LFLetNoEscape {} - -- Shouldn't be possible. I don't think we can export letNoEscapes - -> True + s <- getMap + let get_env_sig = lookupUFM s + massertPpr + -- Assert the env is complete for local lifted binders, which means either + -- - The binder is present in the env + -- - The binder is not a local lifted binder or comes from a ghci context + (isJust (get_env_sig v) + -- See Note [Tag inference for interactive contexts] + || isInteractiveModule this_mod + || not (nameIsLocalOrFrom this_mod (idName v)) + || not (definitelyLiftedType (idType v))) + (text "unknown Id:" <> ppr this_mod <+> ppr v) + -- TODO: We could refactor the whole pass such that we also set id_tagSig + -- for every imported id. But this likely comes with a heavy allocation + -- overhead so for now we just ensure to use the same logic across analysis + -- and rewriter. + pure $! isTaggedInfo $ argTagInfo for_bytecode (get_env_sig v) (StgVarArg v) isArgTagged :: StgArg -> RM Bool @@ -299,11 +276,12 @@ mkLocalArgId id = do --------------------------- -rewriteTopBinds :: Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding] -rewriteTopBinds mod us binds = +rewriteTopBinds :: Bool -- ^ Generating bytecode? + -> Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding] +rewriteTopBinds for_bytecode mod us binds = let doBinds = mapM rewriteTop binds - in evalState (unRM doBinds) (mempty, us, mod, mempty) + in evalState (unRM doBinds) (mempty, us, mod, mempty, for_bytecode) rewriteTop :: InferStgTopBinding -> RM TgStgTopBinding rewriteTop (StgTopStringLit v s) = return $! (StgTopStringLit v s) ===================================== compiler/GHC/Stg/EnforceEpt/Types.hs ===================================== @@ -12,7 +12,7 @@ where import GHC.Prelude import GHC.Core.DataCon -import GHC.Core.Type (isUnliftedType) +import GHC.Core.Type (isUnliftedType, definitelyUnliftedType) import GHC.Types.Id import GHC.Stg.Syntax import GHC.Stg.EnforceEpt.TagSig as TagSig @@ -22,6 +22,7 @@ import GHC.Utils.Misc( zipWithEqual ) import GHC.Utils.Panic import GHC.StgToCmm.Types +import GHC.StgToCmm.Closure (importedIdLFInfo) {- ********************************************************************* * * @@ -97,31 +98,37 @@ lookupReturnInfo env fun = case lookupVarEnv (te_env env) fun of Just (TagVal _) -> Nothing Nothing -> Nothing --- | Look up a value-level tag for an argument: either from the env (where --- a function-typed argument flattens to TagEPT — its closure is tagged) --- or derived from information on the variable itself. -lookupInfo :: TagEnv p -> StgArg -> TagInfo -lookupInfo env (StgVarArg var) +{-# INLINE argTagInfo #-} -- Specialize for the call site. +-- | Look up a value-level tag. +-- +-- If we can do so faster avoid inspecting the env and compute the info from the Id. +-- If we can't check the provided env value or fall back to safe defaults. +argTagInfo :: Bool -> (Maybe TagSig) -> StgArg -> TagInfo +argTagInfo _for_bytecode _env_sig (StgLitArg{}) = TagEPT +argTagInfo for_bytecode env_sig (StgVarArg var) -- Nullary data constructors like True, False | Just dc <- isDataConWorkId_maybe var , isNullaryRepDataCon dc , not for_bytecode = TagEPT - | isUnliftedType (idType var) + -- NB: v might be the Id of a representation-polymorphic join point, + -- so we shouldn't use isUnliftedType here. See T22212. + | definitelyUnliftedType (idType var) = TagEPT -- Variables in the environment. A function binding flattens to TagEPT -- since a function closure pointer is properly tagged; its return info -- is not relevant when the function is used as a value. - | Just sig <- lookupVarEnv (te_env env) var + | Just sig <- env_sig = case sig of TagVal info -> info TagFun _ -> TagEPT - | Just lf_info <- idLFInfo_maybe var - , not for_bytecode - = case lf_info of + | lf_info <- importedIdLFInfo var -- will make up LFInfo if not present. + = if for_bytecode then TagDunno + else + case lf_info of -- Function, tagged (with arity) LFReEntrant {} -> TagEPT @@ -138,13 +145,14 @@ lookupInfo env (StgVarArg var) -- Shouldn't be possible. I don't think we can export letNoEscapes LFLetNoEscape {} -> panic "LFLetNoEscape exported" - | otherwise - = TagDunno - where - for_bytecode = te_bytecode env - -lookupInfo _ (StgLitArg {}) - = TagEPT +-- | Look up a value-level tag for an argument: either from the env (where +-- a function-typed argument flattens to TagEPT — its closure is tagged) +-- or derived from information on the variable itself. +lookupInfo :: TagEnv p -> StgArg -> TagInfo +lookupInfo env arg@(StgVarArg var) = + let env_sig = (lookupVarEnv (te_env env) var) + in argTagInfo (te_bytecode env) env_sig arg +lookupInfo _env (StgLitArg{}) = TagEPT isDunnoSig :: TagSig -> Bool isDunnoSig (TagVal TagDunno) = True ===================================== testsuite/tests/bytecode/T27842.hs ===================================== @@ -0,0 +1,42 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fno-worker-wrapper -fno-cpr-anal #-} +-- Regression test for #27842. +-- +-- The basic rundown is this: +-- We produce one interface file, however we store information dependent on the +-- code generation method in the interface file. +-- +-- We happen to pick the native code information to store in the interface file. +-- +-- When we compile a module M this way, and then generate byte code for code +-- depending on M based on M.hi we will assume certain exported definitions are EPT +-- tagged, despite the interpreter doing no such thing. +-- +-- This then led to crashes in the interpreter. +-- +-- We test three kinds of imported definitions: +-- * mk uses fun, a function whose TagSig says its result is tagged. +-- * bar uses just_con, a value whose LFInfo says it is a constructor. +-- * baz uses gt_con, the same for a nullary constructor. +module Main where + +import T27842A (fun, just_con, gt_con) +import T27842N (S(..), use_S, M(..), use_M, N(..), use_N) + +mk :: Int -> S +mk x = case fun x of (# xs, _ #) -> S xs +{-# NOINLINE mk #-} + +bar :: M +bar = M just_con +{-# NOINLINE bar #-} + +baz :: N +baz = N gt_con +{-# NOINLINE baz #-} + +main :: IO () +main = do + print (use_S (mk 42)) + print (use_M bar) + print (use_N baz) ===================================== testsuite/tests/bytecode/T27842.stdout ===================================== @@ -0,0 +1,3 @@ +42 +42 +3 ===================================== testsuite/tests/bytecode/T27842A.hs ===================================== @@ -0,0 +1,19 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fno-worker-wrapper -fno-cpr-anal #-} +module T27842A (fun, just_con, gt_con) where + +-- The native EPT run gives fun the TagSig TagFun[TagTuple[TagEPT, TagDunno]]: +fun :: Int -> (# [Int], Int #) +fun x = let xs = x : xs in (# xs, x #) +{-# NOINLINE fun #-} + +-- In native code a static constructor, in bytecode an unevaluated closure. +just_con :: Maybe Int +just_con = Just 42 +{-# NOINLINE just_con #-} + +-- The same for a nullary constructor. Without its pointer tag, the object code +-- in T27842N would take the LT alternative, so GT shows the difference. +gt_con :: Ordering +gt_con = GT +{-# NOINLINE gt_con #-} ===================================== testsuite/tests/bytecode/T27842N.hs ===================================== @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -fno-byte-code-and-object-code #-} +-- We compile this module as native code, depending on A's interface file. +-- A itself is loaded into GHCi, despite it's interface file being generated based +-- on native code generation. +module T27842N (S(..), use_S, M(..), use_M, N(..), use_N) where + +data S = S ![Int] + +-- We take apart the strict constructor value and branch on the value in its field. +-- If the field content is not EPT this causes undefined behaviour. + +use_S :: S -> Int +use_S (S xs) = case xs of { (y:_) -> y; [] -> -1 } +{-# NOINLINE use_S #-} + +data M = M !(Maybe Int) + +use_M :: M -> Int +use_M (M m) = case m of { Just x -> x; Nothing -> -1 } +{-# NOINLINE use_M #-} + +data N = N !Ordering + +use_N :: N -> Int +use_N (N o) = case o of { LT -> 1; EQ -> 2; GT -> 3 } +{-# NOINLINE use_N #-} ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -17,3 +17,12 @@ test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script']) test('T27001', [extra_files(['T27001.hs']), req_interp], run_command, ['{compiler} -e main -O -fno-unoptimized-core-for-interpreter T27001.hs']) + +# Bytecode must not trust tag information from imported interfaces, which +# comes from native code (#27842): neither the TagSig of an imported function +# nor the LFInfo of an imported value (with and without constructor fields). +test('T27842', [extra_files(['T27842A.hs', 'T27842N.hs']), req_interp], + run_command, + ['{compiler} -e main -O -fno-unoptimized-core-for-interpreter ' + '-fobject-code -fbyte-code-and-object-code -fwrite-byte-code -fprefer-byte-code ' + 'T27842.hs']) ===================================== testsuite/tests/simplStg/should_compile/all.T ===================================== @@ -25,5 +25,17 @@ test('inferTags003', [ only_ways(['optasm']), ], compile, ['-ddump-cmm -dno-typeable-binds -O']) test('inferTags004', normal, compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques']) test('T27005b', normal, compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques']) +# Both f and the join point j should have a signature TagTuple[TagEPT, TagEPT] +test('inferTags005', + grep_errmsg(r'(TagTuple\[TagEPT, TagEPT\])', [1]), + compile, + ['-O -fno-worker-wrapper -fno-cpr-anal -ddump-stg-tags ' + '-dno-typeable-binds -dsuppress-uniques']) +# The function needs to have a signature TagTuple[TagEPT, TagEPT] +test('inferTags006', + grep_errmsg(r'(TagTuple\[TagEPT, TagEPT\])', [1]), + compile, + ['-O -fno-worker-wrapper -fno-cpr-anal -fno-full-laziness -ddump-stg-tags ' + '-dno-typeable-binds -dsuppress-uniques']) test('T24806', grep_errmsg('^\\(T24806\\.\\$wgo'), compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques']) ===================================== testsuite/tests/simplStg/should_compile/inferTags005.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE UnboxedTuples #-} +module EnforceEpt005 where + +-- If we have +-- f x y = +-- join j = +-- <rhs> -- <TagTuple[TagEPT, TagEPT]]> +-- in case x of +-- 1 -> j +-- 2 -> j +-- _ -> +-- <something> -- <TagTuple[TagEPT, TagEPT]]> + +-- Consider the case where rhs and something both represent a tag value of <TagTuple[TagEPT, TagEPT]]> +-- In this case we want `f` to also give rise to TagFun [TagTuple[TagEPT, TagEPT]]] + +-- To achieve this we have to recognize j as a zero-arity function equivalent +-- which is what this test checks. + +-- The payoff is in `g` `r` is then known to be tagged, so `S r` needs no eval. +-- Only an unboxed tuple result exposes this. + +-- We disable worker/wrapper and CPR so `f` matches more closely the tests source. + +data T = A Int Int Int Int Int Int | B + +f :: Int -> Int -> (# T, T #) +f x y = case x of + 0 -> j + 1 -> j + _ -> (# B, B #) + where + j = (# A (y+1) (y*2) (y-3) (y*y) (y+x) (y*x), B #) +{-# NOINLINE f #-} + +data S = S !T + +g :: Int -> Int -> S +g x y = case f x y of (# r, _ #) -> S r ===================================== testsuite/tests/simplStg/should_compile/inferTags005.stderr ===================================== @@ -0,0 +1,2 @@ +TagTuple[TagEPT, TagEPT] +TagTuple[TagEPT, TagEPT] ===================================== testsuite/tests/simplStg/should_compile/inferTags006.hs ===================================== @@ -0,0 +1,31 @@ +{-# LANGUAGE UnboxedTuples #-} +module EnforceEpt006 where + +-- If we have +-- f x y = +-- join j = +-- <rhs> -- TagBottoming +-- in case x of +-- 1 -> j +-- 2 -> j +-- _ -> +-- <something> -- <TagTuple[TagEPT, TagEPT]]> + +-- Similar to inferTage005 we want to give `f` the signature: TagFun <TagTuple[TagEPT, TagEPT]]> +-- This requires us to give `j` a `TagFun[TagBottoming]` signature, which is safe because +-- either its execution will diverge, or the resulting tuple *will* have two +-- tagged values. + +data T = A Int Int Int Int Int Int | B + +f :: Int -> Int -> (# T, T #) +-- This case-of-case is just here to be optimized into a nullary join point. +f x y = case (case x of { 0 -> False; 1 -> False; _ -> True }) of + False -> error ("f: bad input " ++ show x ++ " " ++ show y ++ " " ++ show (x*y)) + True -> (# A (y+1) (y*2) (y-3) (y*y) (y+x) (y*x), B #) +{-# NOINLINE f #-} + +data S = S !T + +g :: Int -> Int -> S +g x y = case f x y of (# r, _ #) -> S r ===================================== testsuite/tests/simplStg/should_compile/inferTags006.stderr ===================================== @@ -0,0 +1 @@ +TagTuple[TagEPT, TagEPT] ===================================== testsuite/tests/simplStg/should_run/InferTags007_A.hs ===================================== @@ -0,0 +1,20 @@ +-- We suppress arity and LfInfo with the option. +{-# OPTIONS_GHC -fomit-interface-pragmas #-} +module InferTags007_A (fun, caf, bot, con) where + +fun :: Int -> Int +fun x = x + 1 +{-# NOINLINE fun #-} + +-- A CAF/thunk +caf :: [Int] +caf = map (* 2) [1 .. 10] +{-# NOINLINE caf #-} + +bot :: Int -> Int +bot _ = error "bot called" +{-# NOINLINE bot #-} + +con :: Maybe Int +con = Just 42 +{-# NOINLINE con #-} ===================================== testsuite/tests/simplStg/should_run/T27831.hs ===================================== @@ -0,0 +1,35 @@ +-- Regression test for #27831: a bottoming function stored in a strict +-- constructor field. +-- +-- Different parts of the tag inference machinery didn't agree on weither or not +-- a bottoming function should be treated as a EPT value, leading to a segfault. +module Main (main) where + +import Control.Exception +import GHC.Exts.Heap (GenClosure(..), getClosureData) +import System.Exit + +data T = MkT Int !(Int -> Int) + +t :: T +t = MkT 1 (\_ -> error "T27831") +{-# NOINLINE t #-} + +f :: () -> T +f _ = t +{-# OPAQUE f #-} + +main :: IO () +main = do + c <- getClosureData t + case c of + ThunkClosure{} -> putStrLn "FAIL: ThunkClosure" >> exitFailure + APClosure{} -> putStrLn "FAIL: APClosure" >> exitFailure + _ -> putStrLn "OK: not a thunk" + + case f () of MkT n _ -> print n + + r <- try (evaluate (case t of MkT _ g -> g 1)) + case r of + Left (ErrorCall msg) -> putStrLn ("OK: " ++ msg) + Right v -> putStrLn ("FAIL: got " ++ show v) >> exitFailure ===================================== testsuite/tests/simplStg/should_run/T27831.stdout ===================================== @@ -0,0 +1,3 @@ +OK: not a thunk +1 +OK: T27831 ===================================== testsuite/tests/simplStg/should_run/all.T ===================================== @@ -3,13 +3,15 @@ # extra run flags # expected process return value, if not zero -# Only compile with optimisation +# Only run optimised code, native and interpreted: +# We now generate bytecode from STG so we should test native and bytecode. def f( name, opts ): - opts.only_ways = ['optasm'] + opts.only_ways = ['optasm', 'ghci-opt'] setTestOpts(f) -test('T9291', normal, compile_and_run, ['']) +# Breakpoint ticks would break CSE which this tests. +test('T9291', [omit_ways(['ghci']), extra_hc_opts('-fno-break-points')], compile_and_run, ['']) test('T13536', normal, compile_and_run, ['']) test('T13536a', @@ -20,6 +22,15 @@ test('T13536a', test('inferTags001', normal, multimod_compile_and_run, ['inferTags001', 'inferTags001_a']) test('T22042', [extra_files(['T22042a.hs']),only_ways('normal'),unless(have_dynamic(), skip)], makefile_test, ['T22042']) -test('T23783', normal, multimod_compile_and_run, ['T23783', '-O -v0']) -test('unpack_enum', normal, compile_and_run, ['']) -test('T27005a', normal, compile_and_run, ['']) + +# Depends on tag inference being similarly effective for bytecode which it is not yet. +test('T23783', omit_ghci, multimod_compile_and_run, ['T23783', '-O -v0']) + +# Requires UNPACK which needs -O +test('unpack_enum', omit_ways(['ghci']), compile_and_run, ['']) + +# Tests that tag inference optimizes well, which is not the case for bytecode or +# when we insert profiling ticks. +test('T27005a', omit_ways(ghci_ways + prof_ways), compile_and_run, ['']) +test('T27831', omit_ways(ghci_ways + prof_ways), compile_and_run, ['']) +test('inferTags007', [extra_files(['InferTags007_A.hs'])], multimod_compile_and_run, ['inferTags007', '-O -v0']) ===================================== testsuite/tests/simplStg/should_run/inferTags007.hs ===================================== @@ -0,0 +1,109 @@ +{-# LANGUAGE MagicHash #-} +-- This test sanity checks the tag info we generate for imported binders which +-- have no real info in the .hi file. +-- +-- This is important to avoid running into cases where we optimistically +-- generated better information based on things like type than the +-- compiled code actually provided. For example GHCi doesn't ensure tagging +-- of constructors. +module Main (main) where + +import Control.Exception +import Control.Monad +import GHC.Exts (Addr#) +import GHC.Exts.Heap (GenClosure(..), getClosureData) +import GHC.Internal.Control.Exception.Base (patError) +import System.Exit + +import qualified InferTags007_A as A + +data S a = S !a + +data P = MkP !(Addr# -> Int) + +-- Put the imported values into a strict field of a top level Con +con_top_fun :: S (Int -> Int) +con_top_fun = S A.fun +{-# NOINLINE con_top_fun #-} + +con_top_caf :: S [Int] +con_top_caf = S A.caf +{-# NOINLINE con_top_caf #-} + +con_top_bot :: S (Int -> Int) +con_top_bot = S A.bot +{-# NOINLINE con_top_bot #-} + +con_top_con :: S (Maybe Int) +con_top_con = S A.con +{-# NOINLINE con_top_con #-} + +con_top_pat :: P +con_top_pat = MkP patError +{-# NOINLINE con_top_pat #-} + +-- Put the imported values into a strict field of a Con inside a rhs +expr_fun :: () -> S (Int -> Int) +expr_fun _ = S A.fun +{-# OPAQUE expr_fun #-} + +expr_caf :: () -> S [Int] +expr_caf _ = S A.caf +{-# OPAQUE expr_caf #-} + +expr_bot :: () -> S (Int -> Int) +expr_bot _ = S A.bot +{-# OPAQUE expr_bot #-} + +expr_con :: () -> S (Maybe Int) +expr_con _ = S A.con +{-# OPAQUE expr_con #-} + +-- Actually use the field. +use_S_head :: S [Int] -> Int +use_S_head (S xs) = case xs of { (y:_) -> y; [] -> -1 } +{-# NOINLINE use_S_head #-} + +use_S_fromJust :: S (Maybe Int) -> Int +use_S_fromJust (S m) = case m of { Just x -> x; Nothing -> -1 } +{-# NOINLINE use_S_fromJust #-} + +use_S_apply :: S (Int -> Int) -> Int +use_S_apply (S f) = f 1 +{-# NOINLINE use_S_apply #-} + +checkNotThunk :: String -> a -> IO () +checkNotThunk name x = do + c <- getClosureData x + case c of + ThunkClosure{} -> putStrLn ("FAIL: " ++ name ++ " is a thunk") >> exitFailure + APClosure{} -> putStrLn ("FAIL: " ++ name ++ " is an AP") >> exitFailure + _ -> pure () + +-- Pattern matching binds the field itself, so no selector thunk is involved. +checkField :: String -> S a -> IO () +checkField name (S x) = checkNotThunk name x +{-# NOINLINE checkField #-} + +main :: IO () +main = do + -- Check if the pointer in the strict field is a thunk. + checkField "con_top_caf" con_top_caf + checkField "con_top_fun" con_top_fun + checkField "con_top_bot" con_top_bot + checkField "con_top_con" con_top_con + case con_top_pat of MkP f -> checkNotThunk "con_top_pat" f + checkField "expr_caf" (expr_caf ()) + checkField "expr_fun" (expr_fun ()) + checkField "expr_bot" (expr_bot ()) + checkField "expr_con" (expr_con ()) + + -- Actually execute a case on the contents of the field. + print (use_S_head con_top_caf, use_S_head (expr_caf ())) + print (use_S_fromJust con_top_con, use_S_fromJust (expr_con ())) + print (use_S_apply con_top_fun, use_S_apply (expr_fun ())) + forM_ [con_top_bot, expr_bot ()] $ \s -> do + r <- try (evaluate (use_S_apply s)) + case r of + Left (ErrorCall msg) -> putStrLn ("OK: " ++ msg) + Right v -> putStrLn ("FAIL: got " ++ show v) >> exitFailure ===================================== testsuite/tests/simplStg/should_run/inferTags007.stdout ===================================== @@ -0,0 +1,5 @@ +(2,2) +(42,42) +(2,2) +OK: bot called +OK: bot called View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8a51f7e6cd0f0a0eafd1dac69836a39… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8a51f7e6cd0f0a0eafd1dac69836a39… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0