scratch/GC.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2 module GC
   3   ({- dont export generic versions for high performance ;-) -}) where
   4
   5 import Control.Monad
   6
   7 import Data.Foldable hiding (mapM_)
   8
   9 import Foreign.Ptr
  10 import Foreign.Marshal.Alloc
  11 import Foreign.Marshal.Array
  12 import Foreign.Storable
  13 import GHC.Int
  14
  15
  16 class RefObj a where
  17   payload :: a -> IO IntPtr
  18   refs    :: a -> IO [a]
  19   marked  :: a -> IO Bool
  20   mark    :: a -> IO ()
  21
  22
  23 instance RefObj (Ptr a) where
  24   payload     = return . ptrToIntPtr
  25   refs        = unpackRefs . castPtr
  26   marked      = markedRef
  27   mark        = markRef
  28
  29
  30 idOff           = 0x0
  31 numberOfObjsOff = 0x4
  32 fieldsOff = 0xC
  33 markedOff = 0x8
  34
  35 unpackRefs :: Ptr Int32 -> IO [Ptr b]
  36 unpackRefs ptr = do  --dereference number of objs; mark field skipped via fieldsOffset
  37                     numberOfObjs <- peekByteOff ptr numberOfObjsOff :: IO Int32
  38                     mapM (peekElemOff (ptr `plusPtr` fieldsOff)) [0..fromIntegral $ numberOfObjs-1]
  39
  40 markedRef :: Ptr a -> IO Bool
  41 markedRef ptr = liftM ((/=0) . fromIntegral) (peekByteOff ptr markedOff :: IO Int32)
  42
  43 markRef :: Ptr a -> IO ()
  44 markRef ptr = pokeByteOff ptr markedOff (1::Int32)
  45
  46 markTree :: RefObj a => a -> IO ()
  47 markTree root = marked root >>= (`when` continue) . not
  48   where continue = mark root >> refs root >>= mapM_  markTree
  49
  50
  51 emptyObj id  = do mem <- mallocBytes 0xC
  52                   pokeArray mem [id,0,0::Int32]
  53                   return mem
  54
  55 twoRefs = do mem <- mallocBytes 0x14
  56              -- idOfObj; numberofObj; marked waste memory Int32
  57              pokeArray mem [0::Int32,2,0]
  58              obj1 <- emptyObj 1
  59              obj2 <- emptyObj 2
  60              pokeByteOff mem 0xC obj1
  61              pokeByteOff mem (0xC+0x4) obj2
  62              return mem
  63
  64