1 files changed, 82 insertions, 0 deletions
diff --git a/libraries/ghc-heap/tests/create_tso.c b/libraries/ghc-heap/tests/create_tso.c
new file mode 100644
index 0000000000..4b00333197
--- /dev/null
+++ b/libraries/ghc-heap/tests/create_tso.c
@@ -0,0 +1,82 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+
+// Assumes the rts is paused
+void unpack_closure
+    ( StgClosure * inClosure
+    , const StgInfoTable ** outInfoTablePtr
+    , int * outHeapRepSize // Size of outHeapRep (in bytes)
+    , StgWord ** outHeapRep   // Array of words
+    , int * outPointersSize      // Size of outPointers (in words)
+    , StgClosure *** outPointers // Array of all pointers of the TSO
+    )
+{
+    *outInfoTablePtr = get_itbl(inClosure);
+
+    // Copy TSO pointers.
+    StgWord closureSizeW = heap_view_closureSize(inClosure);
+    int closureSizeB = sizeof(StgWord) * closureSizeW;
+    StgClosure ** pointers = malloc(closureSizeB);
+    *outPointersSize = collect_pointers(inClosure, closureSizeW, pointers);
+    *outPointers = pointers;
+
+    // Copy the heap rep.
+    StgWord * heapRep = malloc(closureSizeB);
+    for (int i = 0; i < closureSizeW; i++)
+    {
+        heapRep[i] = ((StgWord*)inClosure)[i];
+    }
+
+    *outHeapRepSize = closureSizeB;
+    *outHeapRep = heapRep;
+}
+
+// Must be called from a safe FFI call.
+void create_and_unpack_tso_and_stack
+    // TSO
+    ( StgTSO ** outTso
+    , const StgInfoTable ** outTsoInfoTablePtr
+    , int * outTsoHeapRepSize // Size of outHeapRep (in bytes)
+    , StgWord ** outTsoHeapRep   // Array of words
+    , int * outTsoPointersSize      // Size of outPointers (in words)
+    , StgClosure *** outTsoPointers // Array of all pointers of the TSO
+    // Stack
+    , StgTSO ** outStack
+    , const StgInfoTable ** outStackInfoTablePtr
+    , int * outStackHeapRepSize // Size of outHeapRep (in bytes)
+    , StgWord ** outStackHeapRep   // Array of words
+    , int * outStackPointersSize      // Size of outPointers (in words)
+    , StgClosure *** outStackPointers // Array of all pointers of the TSO
+    )
+{
+    // Pause RTS
+    PauseToken * token = rts_pause();
+    Capability * cap = pauseTokenCapability(token);
+
+    // Create TSO/Stack
+    HaskellObj trueClosure = rts_mkBool(cap, 1);
+    *outTso = createGenThread(cap, 500U, trueClosure);
+
+    // Unpack TSO
+    unpack_closure(
+        (StgClosure*)(*outTso),
+        outTsoInfoTablePtr,
+        outTsoHeapRepSize,
+        outTsoHeapRep,
+        outTsoPointersSize,
+        outTsoPointers);
+
+    // Unpack STACK
+    StgClosure * outStackAsClosure = (*outTsoPointers)[2];
+    *outStack = (StgTSO *)outStackAsClosure;
+    unpack_closure(
+        outStackAsClosure,
+        outStackInfoTablePtr,
+        outStackHeapRepSize,
+        outStackHeapRep,
+        outStackPointersSize,
+        outStackPointers);
+
+    // Resume RTS
+    rts_resume(token);
+}