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"