scratch/GC.hs

   1 {-# LANGUAGE GADTs #-}
   2 {-# LANGUAGE ExistentialQuantification #-}
   3 module GC where
   4
   5 import Control.Monad
   6
   7 import Foreign.Ptr
   8 import Foreign.Marshal.Alloc
   9 import Foreign.Storable
  10 import Foreign.C.Types
  11 import GHC.Int
  12 import Text.Printf
  13
  14 class RefObject a where
  15   mem  :: a -> IntPtr
  16   refs :: a -> [IntPtr]
  17
  18
  19 data RefObj = RefObj IntPtr [IntPtr] deriving Show
  20
  21 instance RefObject RefObj where
  22   mem  (RefObj mem _ ) = mem
  23   refs (RefObj _ refs) = refs
  24
  25 data Succ = forall a. (RefObject a) => Succ (a -> [a])
  26
  27 obj2 = do buffer <- mallocBytes 4
  28           pokeByteOff buffer 0 (0::Int32)
  29           return buffer
  30
  31 obj3 = do buffer <- mallocBytes 4
  32           pokeByteOff buffer 0 (0::Int32)
  33           return buffer
  34
  35 obj1 f g = do buffer <- mallocBytes 12
  36               pokeByteOff buffer 0 (2::Int32)
  37               pokeByteOff buffer 4 f
  38               pokeByteOff buffer 8 g
  39               return buffer
  40
  41 ptrToRefObj ptr = do objCount <- peek ptr :: IO Int32
  42                      let objsBase = ptr `plusPtr` 4
  43                      objs <- mapM ((liftM ptrToIntPtr) . peekElemOff objsBase . fromIntegral) [0..objCount-1]
  44                      return $ RefObj (ptrToIntPtr ptr) objs
  45
  46 test1 = do f <- obj2
  47            g <- obj3
  48            (print . ptrToIntPtr) f
  49            (print . ptrToIntPtr) g
  50            ptrToRefObj =<< obj1 f g
  51
  52 traverse :: (RefObject a) => (IntPtr -> IO a) -> a -> [a] -> IO [a]
  53 traverse dereference x ws = do children <- mapM dereference (refs x)
  54                                undefined
  55
  56 succMem :: Ptr a -> Succ
  57 succMem =undefined-- Succ (\_ -> obj1
  58
  59
  60