GitLab

Cheng Shao pushed to branch wip/deepseq-primop at Glasgow Haskell Compiler / GHC

Commits:

c1a8508d
by Cheng Shao at 2026-01-20T17:23:07+01:00
```
WIP
```

7 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/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

 +/* -----------------------------------------------------------------------------
 + *
 + * (c) The GHC Team, 2025
 + *
 + * Support for the deepseq# primcall.
 + *
 + * ---------------------------------------------------------------------------*/
++
 +#include "Cmm.h"
++
 +/*
 +Note [import CLOSURE annotations]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +See Note [import CLOSURE annotations] in rts/Apply.cmm.
 +*/
++
 +#if !defined(UnregisterisedCompiler)
 +import CLOSURE g0;
 +import CLOSURE large_alloc_lim;
 +#endif
++
 +/* -----------------------------------------------------------------------------
 +   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) ( likely: False ) {
 +            // 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) ( likely: False ) {
 +            // 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_0_1,
 +        CONSTR_2_0,
 +        CONSTR_1_1,
 +        CONSTR_0_2,
 +        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 = %relaxed StgMutVar_var(p);
 +        jump stg_deepseqWorkzh(p, forced);
 +    }
++
 +    case
 +        MVAR_CLEAN,
 +        MVAR_DIRTY: {
 +        p = %relaxed 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 and
 +    // mutable objects which are not plain containers (e.g. TVar#),
 +    // 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)
 +{
 +    jump stg_deepseqLoopzh(p, 0);
 +}
++
 +// Worker which evaluates to a root and then delegates to the deep traversal.
 +// The second argument is a boolean (0/1) accumulator tracking whether any
 +// evaluation was forced in the transitive closure so far.
 +stg_deepseqLoopzh (P_ p, W_ forced)
 +{
 +    W_ type, info, tag;
++
 +    again: MAYBE_GC(again);
 +    STK_CHK_GEN();
++
 +    tag = GETTAG(p);
 +    p = UNTAG(p);
 +    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_deepseqLoopzh(evald, 1);
 +    }
++
 +    // Follow indirections:
 +    case IND, IND_STATIC: {
 +        p = %acquire StgInd_indirectee(p);
 +        jump stg_deepseqLoopzh(p, forced);
 +    }
++
 +    // WHITEHOLEs are transient. Yield and try again.
 +    case WHITEHOLE: {
 +        goto again;
 +    }
++
 +    default: {
 +        P_ root;
 +        root = tag | p;
 +        (W_ forced1) = call stg_deepseqWorkzh(root, forced);
 +        return (forced1, root);
 +    }}
 +}

libraries/ghc-experimental/ghc-experimental.cabal.in

@@ -31,6 +31,7 @@ library
      exposed-modules:
        Data.Sum.Experimental
        Data.Tuple.Experimental
 +      GHC.DeepSeq
        GHC.PrimOps
        GHC.Profiling.Eras
        GHC.TypeLits.Experimental
@@ -46,4 +47,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

 +{-# 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 (stToIO)
 +import GHC.Internal.ST (ST (..), runST)
++
 +-- | 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# a s0 of
 +  (# s1, flag#, a' #) -> (# s1, (isTrue# flag#, a') #)
++
 +foreign import prim "stg_deepseqzh" deepseqzh# :: Any -> State# s -> (# State# s, Int#, Any #)
++
 +deepseq# :: a -> State# s -> (# State# s, Int#, a #)
 +deepseq# x s0 =
 +  case deepseqzh# (unsafeCoerce# x) s0 of
 +    (# s1, flag#, x' #) -> (# s1, flag#, unsafeCoerce# x' #)

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.PrimOps where
    -- Safety: Unsafe
    (*#) :: Int# -> Int# -> Int#

testsuite/tests/primops/should_run/DeepSeqPrimOp.hs

 +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

 +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, [''])