Add more sanity checking
[ghc-heap-view.git] / Test.hs
1 {-# LANGUAGE MagicHash, BangPatterns #-}
2
3 import GHC.Exts
4 import GHC.HeapView
5 import Control.DeepSeq
6
7 import System.Environment
8 import System.Mem
9
10 import Control.Monad
11
12 l = [1,2,3]
13
14 main = do
15     args <- map length `fmap` getArgs
16     let l2 = 4:l
17     (l ++ l2 ++ args) `deepseq` return ()
18
19     let x = l ++ l2 ++ args
20     performGC
21     cl <- getClosureData l
22     case cl of ConsClosure {} -> return ()
23     unless (name cl == ":") $ do
24         fail "Wrong name"
25
26     cl <- getClosureData l2
27     case cl of ConsClosure {} -> return ()
28     eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox l)
29     unless eq $ do
30         fail "Doesnt reference l"
31
32     cl <- getClosureData args
33     unless (tipe (info cl) == CONSTR_NOCAF_STATIC) $ do
34         fail "Not a CONSTR_NOCAF_STATIC"
35
36     cl <- getClosureData x
37     unless (tipe (info cl) == THUNK_2_0) $ do
38         fail "Not a THUNK_2_0"
39
40
41     let !(I# m) = length args + 42
42     let !(I# m') = length args + 23
43     let f = \x n -> take (I# m + I# x) n ++ args
44         t = f m' l2
45
46     cl <- getClosureData f
47     unless (tipe (info cl) == FUN_1_1) $ do
48         fail "Not a FUN_1_1"
49     unless (dataArgs cl == [42]) $ do
50         fail "Wrong data arg"
51     cl <- getClosureData t
52     unless (tipe (info cl) == THUNK) $ do
53         fail "Not a THUNK"
54     unless (dataArgs cl == [23]) $ do
55         fail "Wrong data arg"
56     eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox f)
57     unless eq $ do
58         fail "t doesnt reference f"
59
60     let x = id (:) () x
61     x `seq` return ()
62     performGC
63     cl <- getClosureData x
64     case cl of ConsClosure {} -> return ()
65     eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox x)
66     unless eq $ do
67         fail "x doesnt reference itself"