+------------------------------------------------------------------------

+section "Forcing evaluation"

+        {Primitives for forcing evaluation within a state thread.}

+------------------------------------------------------------------------

+

+primop DeepSeqOp "deepseq#" GenPrimOp

+   a -> State# s -> (# State# s, Int#, a #)

+   { @'deepseq#' x s@ deeply evaluates @x@ in the state thread; see

+     'GHC.DeepSeq.forceIO' for the user-facing semantics. }

+   with

+   out_of_line = True

+   effect = ReadWriteEffect

+   -- See Note [seq# magic] in GHC.Types.Id.Make: we must not let strictness

+   -- analysis see through the sequencing effect.

+   strictness = { \ _arity -> mkClosedDmdSig [ topDmd, topDmd ] topDiv }

+

+

+  DeepSeqOp -> alwaysExternal

+  DeepSeqOp                         -> unhandledPrimop op

+

+  -- Users should use the interface provided by GHC.DeepSeq in

+  -- ghc-experimental.

+  , deepseq#

+  -- Users should use the interface provided by GHC.DeepSeq in

+  -- ghc-experimental.

+  , deepseq#

+

+      GHC.DeepSeq

+{-# LANGUAGE MagicHash #-}

+{-# LANGUAGE UnboxedTuples #-}

+

+module GHC.DeepSeq

+  ( force,

+    forceIO,

+  )

+where

+

+import GHC.IO

+import GHC.Internal.Exts

+

+-- | Pure wrapper around 'forceIO'.

+force :: a -> (Bool, a)

+force = unsafePerformIO . forceIO

+

+-- | 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#', 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. 'TVar#'). 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 = IO $ \s0 -> case deepseq# a s0 of

+  (# s1, flag#, a' #) -> (# s1, (isTrue# flag#, a') #)

+/* -----------------------------------------------------------------------------

+ *

+ * (c) The GHC Team, 2025

+ *

+ * Support for the deepseq# primop.

+ *

+ * ---------------------------------------------------------------------------*/

+

+#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 primop documentation in compiler/GHC/Builtin/primops.txt.pp 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);

+    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 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);

+    }}

+}

+      SymI_HasDataProto(stg_deepseqzh)                                      \

+RTS_FUN_DECL(stg_deepseqzh);

+                   DeepSeq.cmm

+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)

+

+  deepseq# :: forall a d. a -> State# d -> (# State# d, Int#, a #)

+  deepseq# :: forall a d. a -> State# d -> (# State# d, Int#, a #)

+  deepseq# :: forall a s. a -> GHC.Internal.Prim.State# s -> (# GHC.Internal.Prim.State# s, GHC.Internal.Prim.Int#, a #)

+module Main (main) where

+

+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar)

+import Control.Exception (SomeException, try)

+import Data.Array (Array, listArray)

+import Data.Array.IO (IOArray, newArray)

+import Data.IORef (IORef, newIORef)

+import GHC.DeepSeq (forceIO)

+import System.Mem.Weak (mkWeak)

+

+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"

+

+  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"

+

+  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"

+thunk-forced

+fun-ok

+noforce-ok

+thunk-ok

+array-thunk-forced

+ioarray-thunk-forced

+ioref-thunk-forced

+mvar-thunk-forced

+weak-thunk-forced

+test('DeepSeqPrimOp', [js_skip, extra_ways(['ghci','ghci-opt']), extra_hc_opts('-package ghc-experimental')], compile_and_run, [''])