Disable the BCO disassembler
[ghc-heap-view.git] / Test.hs
1 {-# LANGUAGE MagicHash, BangPatterns, CPP #-}
2
3 import GHC.Exts
4 import GHC.HeapView
5
6 import Control.DeepSeq
7 import Control.Monad
8 import Control.Applicative (pure)
9
10 import System.Environment
11 import System.Mem
12
13
14 main :: IO ()
15 main = do
16     args <- map length `fmap` getArgs
17     let list2 = 4:list
18     (list ++ list2 ++ args) `deepseq` pure ()
19
20     let x = list ++ list2 ++ args
21     performGC
22     getClosureAssert list >>= \ cl ->
23         unless (name cl == ":") $ fail "Wrong name"
24
25     getClosureAssert list2 >>= \ cl -> do
26         eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox list)
27         unless eq $ fail "Doesn't reference list"
28
29     getClosureData args >>= \ cl ->
30 #if MIN_VERSION_GLASGOW_HASKELL(8,1,0,0)
31         assertClosureType CONSTR_0_1 (info cl)
32 #else
33         assertClosureType CONSTR_NOCAF_STATIC (info cl)
34 #endif
35
36     getClosureData x >>= \ cl ->
37         assertClosureType THUNK_2_0 (info cl)
38
39     let !(I# m) = length args + 42
40     let !(I# m') = length args + 23
41     let f = \ y n -> take (I# m + I# y) n ++ args
42     performGC
43
44     getClosureData f >>= \ cl -> do
45         assertClosureType FUN_1_1 (info cl)
46         unless (dataArgs cl == [42]) $ do
47             fail "Wrong data arg"
48
49     let t = f m' list2
50     getClosureData t >>= \ cl -> do
51         assertClosureType THUNK (info cl)
52         unless (dataArgs cl == [23]) $ do
53             fail "Wrong data arg"
54
55         eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox f)
56         unless eq $ fail "t doesnt reference f"
57
58     let z = id (:) () z
59     z `seq` pure ()
60     performGC
61     getClosureAssert z >>= \ cl -> do
62         eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox z)
63         unless eq $
64             fail "z doesnt reference itself"
65
66     putStrLn "Done. No errors."
67
68
69 list :: [Int]
70 list = [1,2,3]
71
72
73 getClosureAssert :: a -> IO Closure
74 getClosureAssert x = do
75     cl <- getClosureData x
76     case cl of
77         ConsClosure {} -> pure cl
78         _ -> fail "Expected ConsClosure"
79
80
81 assertClosureType :: ClosureType -> StgInfoTable -> IO ()
82 assertClosureType expected itable = do
83     let actual = tipe itable
84     unless (actual == expected) $
85         fail $ "Expected " ++ show expected ++ " but got " ++ show actual