Cheng Shao pushed to branch wip/deepseq-primop at Glasgow Haskell Compiler / GHC Commits: 10ccc7a3 by Cheng Shao at 2026-01-29T03:44:23+01:00 WIP - - - - - 8 changed files: - + libraries/ghc-experimental/cbits/DeepSeq.cmm - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/GHC/DeepSeq.hs - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - + testsuite/tests/primops/should_run/DeepSeqPrimOp.hs - + testsuite/tests/primops/should_run/DeepSeqPrimOp.stdout - testsuite/tests/primops/should_run/all.T Changes: ===================================== libraries/ghc-experimental/cbits/DeepSeq.cmm ===================================== @@ -0,0 +1,190 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 2026 + * + * Support for the deepseq# primcall. + * + * ---------------------------------------------------------------------------*/ + +#include "Cmm.h" + +/* ----------------------------------------------------------------------------- + deepseq# + + Deeply evaluate a value to (approximate) normal form, without requiring an + NFData constraint. This is used to provide a primitive analogue of + Control.DeepSeq.force / rnf. + + See the GHC.DeepSeq documentation for the intended semantics and + limitations. + -------------------------------------------------------------------------- */ + +// Worker which performs deep evaluation. This lets us tail-call when traversing +// the final pointer field, avoiding stack blowup on common spine-recursive +// structures (e.g. lists). +// +// The second argument is a boolean (0/1) accumulator tracking whether any +// evaluation was forced in the transitive closure so far. +stg_deepseqWorkzh (P_ p, W_ forced) +{ + W_ type, info; + + again: MAYBE_GC(again); + STK_CHK_GEN(); + + p = UNTAG(p); + // Values in compact regions are already fully evaluated. + (W_ in_compact) = call stg_compactContainsAnyzh(p); + if (in_compact != 0) { + return (forced); + } + info = %INFO_PTR(p); + type = TO_W_(%INFO_TYPE(%STD_INFO(info))); + + switch [0 .. N_CLOSURE_TYPES] type { + + // Unevaluated things must be evaluated first: + case + THUNK, + THUNK_1_0, + THUNK_0_1, + THUNK_2_0, + THUNK_1_1, + THUNK_0_2, + THUNK_STATIC, + AP, + AP_STACK, + BLACKHOLE, + THUNK_SELECTOR : { + (P_ evald) = call %ENTRY_CODE(info) (p); + jump stg_deepseqWorkzh(evald, 1); + } + + // Follow indirections: + case IND, IND_STATIC: { + p = %acquire StgInd_indirectee(p); + jump stg_deepseqWorkzh(p, forced); + } + + // WHITEHOLEs are transient. Yield and try again. + case WHITEHOLE: { + goto again; + } + + // Arrays of pointers: evaluate elements. + case + MUT_ARR_PTRS_DIRTY, + MUT_ARR_PTRS_CLEAN, + MUT_ARR_PTRS_FROZEN_DIRTY, + MUT_ARR_PTRS_FROZEN_CLEAN: { + W_ i_arr, ptrs_arr; + ptrs_arr = StgMutArrPtrs_ptrs(p); + if (ptrs_arr == 0) { return (forced); } + i_arr = ptrs_arr - 1; + deepseq_arr_loop0: + if (i_arr == 0) { + // Tail-call the final element to avoid building up a deep stack + // when traversing large immutable arrays. + jump stg_deepseqWorkzh(P_[p + SIZEOF_StgMutArrPtrs], forced); + } + (W_ forced_arr) = call stg_deepseqWorkzh(P_[p + SIZEOF_StgMutArrPtrs + WDS(i_arr)], forced); + forced = forced_arr; + i_arr = i_arr - 1; + goto deepseq_arr_loop0; + } + + case + SMALL_MUT_ARR_PTRS_DIRTY, + SMALL_MUT_ARR_PTRS_CLEAN, + SMALL_MUT_ARR_PTRS_FROZEN_DIRTY, + SMALL_MUT_ARR_PTRS_FROZEN_CLEAN: { + W_ i_sarr, ptrs_sarr; + ptrs_sarr = StgSmallMutArrPtrs_ptrs(p); + if (ptrs_sarr == 0) { return (forced); } + i_sarr = ptrs_sarr - 1; + deepseq_arr_loop1: + if (i_sarr == 0) { + // Tail-call the final element to avoid building up a deep stack + // when traversing large immutable arrays. + jump stg_deepseqWorkzh(P_[p + SIZEOF_StgSmallMutArrPtrs], forced); + } + (W_ forced_sarr) = call stg_deepseqWorkzh(P_[p + SIZEOF_StgSmallMutArrPtrs + WDS(i_sarr)], forced); + forced = forced_sarr; + i_sarr = i_sarr - 1; + goto deepseq_arr_loop1; + } + + // Constructors: evaluate their pointer fields. + case + CONSTR, + CONSTR_1_0, + CONSTR_2_0, + CONSTR_1_1, + CONSTR_NOCAF: { + W_ i_constr, ptrs_constr; + ptrs_constr = TO_W_(%INFO_PTRS(%STD_INFO(info))); + if (ptrs_constr == 0) { return (forced); } + i_constr = 0; + deepseq_constr_loop: + if (i_constr < ptrs_constr) { + // Tail-call the last one. This avoids building up a deep stack + // when traversing long lists. We count up so the final pointer + // field (e.g. the tail of a list cell) is tail-called. + if (i_constr == ptrs_constr - 1) { + jump stg_deepseqWorkzh(StgClosure_payload(p,i_constr), forced); + } + (W_ forced_constr) = call stg_deepseqWorkzh(StgClosure_payload(p,i_constr), forced); + forced = forced_constr; + i_constr = i_constr + 1; + goto deepseq_constr_loop; + } + return (forced); + } + + case + MUT_VAR_CLEAN, + MUT_VAR_DIRTY: { + p = StgMutVar_var(p); + jump stg_deepseqWorkzh(p, forced); + } + + case + MVAR_CLEAN, + MVAR_DIRTY: { + p = StgMVar_value(p); + jump stg_deepseqWorkzh(p, forced); + } + + case TVAR: { + (P_ tvar_val) = call stg_readTVarIOzh(p); + jump stg_deepseqWorkzh(tvar_val, forced); + } + + case WEAK: { + // Follow the value of a live weak pointer. + jump stg_deepseqWorkzh(StgWeak_value(p), forced); + } + + // Anything else: conservatively stop. + // + // This includes (among other closure types) function-like closures, TSOs, etc, + // matching the intended "mimic typical NFData instances" semantics + // described in the primop documentation. + // + // We should never see frames here, but if we do, returning is safer than + // entering arbitrary things. + default: { + return (forced); + }} +} + +// deepseq# primop entry point. +// deepseq# :: forall a s. a -> State# s -> (# State# s, Int#, a #) +// +// The State# argument/result has no runtime representation, so the RTS entry +// only takes the value being forced. +stg_deepseqzh (P_ p) +{ + (W_ forced) = call stg_deepseqWorkzh(p, 0); + return (forced, p); +} ===================================== libraries/ghc-experimental/ghc-experimental.cabal.in ===================================== @@ -35,6 +35,7 @@ library exposed-modules: Data.Sum.Experimental Data.Tuple.Experimental + GHC.DeepSeq GHC.PrimOps GHC.Profiling.Eras GHC.TypeLits.Experimental @@ -51,4 +52,5 @@ library build-depends: base >=4.20 && < 4.23, ghc-internal == @ProjectVersionForLib@.* hs-source-dirs: src + cmm-sources: cbits/DeepSeq.cmm default-language: Haskell2010 ===================================== libraries/ghc-experimental/src/GHC/DeepSeq.hs ===================================== @@ -0,0 +1,57 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module GHC.DeepSeq + ( force, + forceIO, + forceST, + ) +where + +import GHC.Internal.Exts +import GHC.Internal.IO +import GHC.Internal.ST + +-- | Pure wrapper around 'forceST'. +force :: a -> (Bool, a) +force a = runST (forceST a) + +-- | Deeply evaluate a value in the 'IO' monad, returning the forced value and +-- a flag indicating whether any unevaluated closure was forced. +-- +-- This is a primitive analogue of 'Control.DeepSeq.force' / @rnf@ that does +-- not require an 'NFData' constraint. It traverses algebraic data (constructor +-- fields), immutable arrays, and the contents of 'MutVar#', 'MVar#', +-- 'MutableArray#', 'SmallMutableArray#', 'TVar#', and live 'Weak#' values. +-- +-- To mimic typical 'Control.DeepSeq.NFData' instances, it stops at +-- function-like closures (e.g. functions and partial applications) and at +-- mutable objects which are not plain containers (e.g. 'MutableByteArray#'). +-- Consequently +-- it is not a drop-in replacement for user-defined 'NFData' instances, which +-- may choose to force less (or more) depending on semantics. +-- +-- === Pointer traversal policy +-- +-- We only follow a pointer when doing so is also possible in Haskell via a +-- corresponding API. For example, we traverse 'MutVar#', 'MVar#', mutable +-- arrays, and live weak pointers because you can observe their contents with +-- operations like @readIORef@, @readMVar@, @readArray@, or @deRefWeak@. +-- Conversely, we do not peek inside closures whose internals are not +-- observable from Haskell, such as function closures and their captured free +-- variables. +-- +-- Like any deep evaluation, it may not terminate on cyclic structures. +forceIO :: a -> IO (Bool, a) +forceIO a = stToIO (forceST a) + +-- | Deeply evaluate a value in the strict 'ST' monad. +forceST :: a -> ST s (Bool, a) +forceST a = ST $ \s0 -> + case deepseq# (unsafeCoerce# a) s0 of + (# s1, flag#, a' #) -> (# s1, (isTrue# flag#, unsafeCoerce# a') #) + +foreign import prim "stg_deepseqzh" deepseq# :: Any -> State# s -> (# State# s, Int#, Any #) ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout ===================================== @@ -4454,6 +4454,12 @@ module Data.Tuple.Experimental where data Unit# = ... getSolo :: forall a. Solo a -> a +module GHC.DeepSeq where + -- Safety: None + force :: forall a. a -> (GHC.Internal.Types.Bool, a) + forceIO :: forall a. a -> GHC.Internal.Types.IO (GHC.Internal.Types.Bool, a) + forceST :: forall a s. a -> GHC.Internal.ST.ST s (GHC.Internal.Types.Bool, a) + module GHC.Exception.Backtrace.Experimental where -- Safety: None type BacktraceMechanism :: * ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 ===================================== @@ -4454,6 +4454,12 @@ module Data.Tuple.Experimental where data Unit# = ... getSolo :: forall a. Solo a -> a +module GHC.DeepSeq where + -- Safety: None + force :: forall a. a -> (GHC.Internal.Types.Bool, a) + forceIO :: forall a. a -> GHC.Internal.Types.IO (GHC.Internal.Types.Bool, a) + forceST :: forall a s. a -> GHC.Internal.ST.ST s (GHC.Internal.Types.Bool, a) + module GHC.Exception.Backtrace.Experimental where -- Safety: None type BacktraceMechanism :: * ===================================== testsuite/tests/primops/should_run/DeepSeqPrimOp.hs ===================================== @@ -0,0 +1,121 @@ +module Main (main) where + +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar) +import Control.Concurrent.STM (TVar, newTVarIO) +import Control.Exception (SomeException, evaluate, try) +import Data.Array (Array, listArray) +import Data.Array.IO (IOArray, newArray) +import Data.IORef (IORef, newIORef) +import GHC.DeepSeq (force, forceIO, forceST) +import GHC.Compact (compactWithSharing, getCompact) +import GHC.ST (runST) +import System.Mem.Weak (mkWeak) +import System.Timeout (timeout) + +deepEvaluate :: a -> IO a +deepEvaluate a = do + (_, a') <- forceIO a + pure a' + +deepEvaluateWithFlag :: a -> IO (Bool, a) +deepEvaluateWithFlag = forceIO + +mkThunk :: Int -> Int +mkThunk x = x + 1 +{-# NOINLINE mkThunk #-} + +boomVal :: Int +boomVal = error "boom" +{-# NOINLINE boomVal #-} + +funVal :: Int -> Int +funVal _ = boomVal +{-# NOINLINE funVal #-} + +main :: IO () +main = do + r1 <- try (deepEvaluate (1 :: Int, error "boom") >> pure ()) :: IO (Either SomeException ()) + case r1 of + Left _ -> putStrLn "thunk-forced" + Right _ -> putStrLn "unexpected-no-exn" + + r2 <- try (deepEvaluate funVal) :: IO (Either SomeException (Int -> Int)) + case r2 of + Left _ -> putStrLn "unexpected-exn" + Right _ -> putStrLn "fun-ok" + + (forced2, ()) <- deepEvaluateWithFlag () + if not forced2 + then putStrLn "noforce-ok" + else putStrLn "noforce-bad" + + x <- evaluate (42 :: Int) + (forced2b, _) <- deepEvaluateWithFlag x + if not forced2b + then putStrLn "noforce-int-ok" + else putStrLn "noforce-int-bad" + + let (forced2c, _) = force x + if not forced2c + then putStrLn "force-int-ok" + else putStrLn "force-int-bad" + + let (forced2d, _) = runST (forceST x) + if not forced2d + then putStrLn "forcest-int-ok" + else putStrLn "forcest-int-bad" + + let v = (1 :: Int, mkThunk 2) + (forced3, v') <- deepEvaluateWithFlag v + if forced3 && snd v' == 3 + then putStrLn "thunk-ok" + else putStrLn "unexpected" + + let arr :: Array Int Int + arr = listArray (0, 0) [boomVal] + r3 <- try (deepEvaluate arr >> pure ()) :: IO (Either SomeException ()) + case r3 of + Left _ -> putStrLn "array-thunk-forced" + Right _ -> putStrLn "array-unforced" + + ioArr <- newArray (0, 0) boomVal :: IO (IOArray Int Int) + r4 <- try (deepEvaluate ioArr >> pure ()) :: IO (Either SomeException ()) + case r4 of + Left _ -> putStrLn "ioarray-thunk-forced" + Right _ -> putStrLn "ioarray-unforced" + + ref <- newIORef boomVal :: IO (IORef Int) + r5 <- try (deepEvaluate ref >> pure ()) :: IO (Either SomeException ()) + case r5 of + Left _ -> putStrLn "ioref-thunk-forced" + Right _ -> putStrLn "ioref-unforced" + + mvar <- newEmptyMVar :: IO (MVar Int) + putMVar mvar boomVal + r6 <- try (deepEvaluate mvar >> pure ()) :: IO (Either SomeException ()) + case r6 of + Left _ -> putStrLn "mvar-thunk-forced" + Right _ -> putStrLn "mvar-unforced" + + tvar <- newTVarIO boomVal :: IO (TVar Int) + r6b <- try (deepEvaluate tvar >> pure ()) :: IO (Either SomeException ()) + case r6b of + Left _ -> putStrLn "tvar-thunk-forced" + Right _ -> putStrLn "tvar-unforced" + + keyRef <- newIORef () + weak <- mkWeak keyRef boomVal Nothing + r7 <- try (deepEvaluate weak >> pure ()) :: IO (Either SomeException ()) + case r7 of + Left _ -> putStrLn "weak-thunk-forced" + Right _ -> putStrLn "weak-unforced" + + let cyclic :: [Int] + cyclic = let xs = 1 : xs in xs + compacted <- compactWithSharing cyclic + let cyclic' = getCompact compacted + _ <- evaluate cyclic' + r8 <- timeout 2000000 (deepEvaluateWithFlag cyclic') + case r8 of + Nothing -> putStrLn "compact-loop-timeout" + Just _ -> putStrLn "compact-loop-ok" ===================================== testsuite/tests/primops/should_run/DeepSeqPrimOp.stdout ===================================== @@ -0,0 +1,14 @@ +thunk-forced +fun-ok +noforce-ok +noforce-int-ok +force-int-ok +forcest-int-ok +thunk-ok +array-thunk-forced +ioarray-thunk-forced +ioref-thunk-forced +mvar-thunk-forced +tvar-thunk-forced +weak-thunk-forced +compact-loop-ok ===================================== testsuite/tests/primops/should_run/all.T ===================================== @@ -17,6 +17,7 @@ test('T13825-compile', normal, compile_and_run, ['']) test('T16164', normal, compile_and_run, ['']) test('ShowPrim', normal, compile_and_run, ['']) test('T12492', normal, compile_and_run, ['']) +test('DeepSeqPrimOp', [js_skip, extra_ways(['ghci','ghci-opt']), extra_hc_opts('-package ghc-experimental -package ghc-compact')], compile_and_run, ['']) test('ArithInt8', normal, compile_and_run, ['']) test('ArithWord8', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/10ccc7a3712d9b8fa8d62a5d0d61f466... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/10ccc7a3712d9b8fa8d62a5d0d61f466... You're receiving this email because of your account on gitlab.haskell.org.