summaryrefslogtreecommitdiff
path: root/libraries/ghc-heap/tests
diff options
context:
space:
mode:
Diffstat (limited to 'libraries/ghc-heap/tests')
-rw-r--r--libraries/ghc-heap/tests/TestUtils.hs7
-rw-r--r--libraries/ghc-heap/tests/all.T15
-rw-r--r--libraries/ghc-heap/tests/create_tso.c82
-rw-r--r--libraries/ghc-heap/tests/create_tso.h19
-rw-r--r--libraries/ghc-heap/tests/parse_tso_flags.hs17
-rw-r--r--libraries/ghc-heap/tests/tso_and_stack_closures.hs167
6 files changed, 307 insertions, 0 deletions
diff --git a/libraries/ghc-heap/tests/TestUtils.hs b/libraries/ghc-heap/tests/TestUtils.hs
new file mode 100644
index 0000000000..4f297cae3a
--- /dev/null
+++ b/libraries/ghc-heap/tests/TestUtils.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE MagicHash #-}
+module TestUtils where
+
+assertEqual :: (Show a, Eq a) => a -> a -> IO ()
+assertEqual a b
+ | a /= b = error (show a ++ " /= " ++ show b)
+ | otherwise = return ()
diff --git a/libraries/ghc-heap/tests/all.T b/libraries/ghc-heap/tests/all.T
index 89e6f47ecb..fcafb9fa45 100644
--- a/libraries/ghc-heap/tests/all.T
+++ b/libraries/ghc-heap/tests/all.T
@@ -36,3 +36,18 @@ test('closure_size_noopt',
],
compile_and_run, [''])
+test('tso_and_stack_closures',
+ [extra_files(['create_tso.c','create_tso.h','TestUtils.hs']),
+ only_ways(['profthreaded']),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ multi_compile_and_run, ['tso_and_stack_closures', [('create_tso.c','')], ''])
+
+test('parse_tso_flags',
+ [extra_files(['TestUtils.hs']),
+ only_ways(['normal']),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ compile_and_run, [''])
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);
+}
diff --git a/libraries/ghc-heap/tests/create_tso.h b/libraries/ghc-heap/tests/create_tso.h
new file mode 100644
index 0000000000..1c24cc2e82
--- /dev/null
+++ b/libraries/ghc-heap/tests/create_tso.h
@@ -0,0 +1,19 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+
+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
+ );
diff --git a/libraries/ghc-heap/tests/parse_tso_flags.hs b/libraries/ghc-heap/tests/parse_tso_flags.hs
new file mode 100644
index 0000000000..51802a32be
--- /dev/null
+++ b/libraries/ghc-heap/tests/parse_tso_flags.hs
@@ -0,0 +1,17 @@
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.FFIClosures
+import TestUtils
+
+main :: IO()
+main = do
+ assertEqual (parseTsoFlags 0) []
+ assertEqual (parseTsoFlags 1) [TsoFlagsUnknownValue 1]
+ assertEqual (parseTsoFlags 2) [TsoLocked]
+ assertEqual (parseTsoFlags 4) [TsoBlockx]
+ assertEqual (parseTsoFlags 8) [TsoInterruptible]
+ assertEqual (parseTsoFlags 16) [TsoStoppedOnBreakpoint]
+ assertEqual (parseTsoFlags 64) [TsoMarked]
+ assertEqual (parseTsoFlags 128) [TsoSqueezed]
+ assertEqual (parseTsoFlags 256) [TsoAllocLimit]
+
+ assertEqual (parseTsoFlags 6) [TsoLocked, TsoBlockx]
diff --git a/libraries/ghc-heap/tests/tso_and_stack_closures.hs b/libraries/ghc-heap/tests/tso_and_stack_closures.hs
new file mode 100644
index 0000000000..42e871bb1f
--- /dev/null
+++ b/libraries/ghc-heap/tests/tso_and_stack_closures.hs
@@ -0,0 +1,167 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import Control.Monad (forM_, unless)
+import Data.List (find)
+import Data.Word
+import Foreign
+import Foreign.C.Types
+import GHC.IO ( IO(..) )
+import GHC.Exts
+import GHC.Exts.Heap
+import qualified GHC.Exts.Heap.FFIClosures as FFIClosures
+import GHC.Word
+
+import TestUtils
+
+main :: IO ()
+main = do
+ (tso, stack) <- {-# SCC "MyCostCentre" #-} createAndUnpackTSOAndSTACKClosure
+ assertEqual (getClosureType tso) TSO
+ assertEqual (what_next tso) ThreadRunGHC
+ assertEqual (why_blocked tso) NotBlocked
+ assertEqual (saved_errno tso) 0
+ forM_ (flags tso) $ \flag -> case flag of
+ TsoFlagsUnknownValue _ -> error $ "Unknown flag: " ++ show flag
+ _ | flag `elem`
+ [ TsoLocked
+ , TsoBlockx
+ , TsoStoppedOnBreakpoint
+ , TsoSqueezed
+ ] -> error $ "Unexpected flag: " ++ show flag
+ _ -> return ()
+
+ assertEqual (getClosureType stack) STACK
+
+#if defined(PROFILING)
+ let costCentre = ccs_cc <$> (cccs =<< prof tso)
+ case costCentre of
+ Nothing -> error $ "No CostCentre found in TSO: " ++ show tso
+ Just _ -> case findMyCostCentre (linkedCostCentres costCentre) of
+ Just myCostCentre -> do
+ assertEqual (cc_label myCostCentre) "MyCostCentre"
+ assertEqual (cc_module myCostCentre) "Main"
+ assertEqual (cc_srcloc myCostCentre) (Just "tso_and_stack_closures.hs:23:48-80")
+ assertEqual (cc_is_caf myCostCentre) False
+ Nothing -> error $ "MyCostCentre not found in:\n" ++ unlines (cc_label <$> linkedCostCentres costCentre)
+#endif
+
+linkedCostCentres :: Maybe CostCentre -> [CostCentre]
+linkedCostCentres Nothing = []
+linkedCostCentres (Just cc) = cc : linkedCostCentres (cc_link cc)
+
+findMyCostCentre:: [CostCentre] -> Maybe CostCentre
+findMyCostCentre ccs = find (\cc -> cc_label cc == "MyCostCentre") ccs
+
+getClosureType :: GenClosure b -> ClosureType
+getClosureType = tipe . info
+
+type StgTso = Any
+type StgStack = Any
+data MBA a = MBA (MutableByteArray# a)
+data BA = BA ByteArray#
+
+foreign import ccall safe "create_tso.h create_and_unpack_tso_and_stack"
+ c_create_and_unpack_tso_and_stack
+ :: Ptr (Ptr StgTso)
+ -> Ptr (Ptr StgInfoTable)
+ -> Ptr CInt
+ -> Ptr (Ptr Word8)
+ -> Ptr CInt
+ -> Ptr (Ptr (Ptr Any))
+ -> Ptr (Ptr StgStack)
+ -> Ptr (Ptr StgInfoTable)
+ -> Ptr CInt
+ -> Ptr (Ptr Word8)
+ -> Ptr CInt
+ -> Ptr (Ptr (Ptr Any))
+ -> IO ()
+
+createAndUnpackTSOAndSTACKClosure
+ :: IO ( GenClosure (Ptr Any)
+ , GenClosure (Ptr Any)
+ )
+createAndUnpackTSOAndSTACKClosure = do
+
+ alloca $ \ptrPtrTso -> do
+ alloca $ \ptrPtrTsoInfoTable -> do
+ alloca $ \ptrTsoHeapRepSize -> do
+ alloca $ \ptrPtrTsoHeapRep -> do
+ alloca $ \ptrTsoPointersSize -> do
+ alloca $ \ptrPtrPtrTsoPointers -> do
+
+ alloca $ \ptrPtrStack -> do
+ alloca $ \ptrPtrStackInfoTable -> do
+ alloca $ \ptrStackHeapRepSize -> do
+ alloca $ \ptrPtrStackHeapRep -> do
+ alloca $ \ptrStackPointersSize -> do
+ alloca $ \ptrPtrPtrStackPointers -> do
+
+ c_create_and_unpack_tso_and_stack
+
+ ptrPtrTso
+ ptrPtrTsoInfoTable
+ ptrTsoHeapRepSize
+ ptrPtrTsoHeapRep
+ ptrTsoPointersSize
+ ptrPtrPtrTsoPointers
+
+ ptrPtrStack
+ ptrPtrStackInfoTable
+ ptrStackHeapRepSize
+ ptrPtrStackHeapRep
+ ptrStackPointersSize
+ ptrPtrPtrStackPointers
+
+ let fromHeapRep
+ ptrPtrClosureInfoTable
+ ptrClosureHeapRepSize
+ ptrPtrClosureHeapRep
+ ptrClosurePointersSize
+ ptrPtrPtrClosurePointers = do
+ ptrInfoTable :: Ptr StgInfoTable <- peek ptrPtrClosureInfoTable
+
+ heapRepSize :: Int <- fromIntegral <$> peek ptrClosureHeapRepSize
+ let I# heapRepSize# = heapRepSize
+ ptrHeapRep :: Ptr Word8 <- peek ptrPtrClosureHeapRep
+ MBA mutHeapRepBA <- IO $ \s -> let
+ (# s', mba# #) = newByteArray# heapRepSize# s
+ in (# s', MBA mba# #)
+ forM_ [0..heapRepSize-1] $ \i@(I# i#) -> do
+ W8# w <- peekElemOff ptrHeapRep i
+ IO (\s -> (# writeWord8Array# mutHeapRepBA i# (extendWord8# w) s, () #))
+ BA heapRep <- IO $ \s -> let
+ (# s', ba# #) = unsafeFreezeByteArray# mutHeapRepBA s
+ in (# s', BA ba# #)
+
+ pointersSize :: Int <- fromIntegral <$> peek ptrClosurePointersSize
+ ptrPtrPointers :: Ptr (Ptr Any) <- peek ptrPtrPtrClosurePointers
+ ptrPtrPointers :: [Ptr Any] <- sequence
+ [ peekElemOff ptrPtrPointers i
+ | i <- [0..pointersSize-1]
+ ]
+
+ getClosureDataFromHeapRep
+ heapRep
+ ptrInfoTable
+ ptrPtrPointers
+
+ tso <- fromHeapRep
+ ptrPtrTsoInfoTable
+ ptrTsoHeapRepSize
+ ptrPtrTsoHeapRep
+ ptrTsoPointersSize
+ ptrPtrPtrTsoPointers
+
+ stack <- fromHeapRep
+ ptrPtrStackInfoTable
+ ptrStackHeapRepSize
+ ptrPtrStackHeapRep
+ ptrStackPointersSize
+ ptrPtrPtrStackPointers
+
+ return (tso, stack)
View Lorry Controller Status