Mate/ClassHierarchy.hs

   1 module Mate.ClassHierarchy
   2   ( isInstanceOf
   3   , addClassEntry
   4   ) where
   5
   6 import qualified Data.Map as M
   7 import qualified Data.ByteString.Lazy as B
   8 import Control.Applicative
   9 import Control.Monad
  10 import Text.Printf
  11
  12 import Foreign
  13 import Data.IORef
  14
  15 import Mate.NativeSizes
  16 import Mate.ClassPool
  17
  18
  19 data Class
  20   = Class
  21     { clMtable :: NativeWord
  22     , clSuperClass :: NativeWord
  23     , clInterfaces :: [Interface]
  24     }
  25   | JavaLangObject
  26     { clMtable :: NativeWord
  27     }
  28
  29 data Interface
  30   = Interface
  31     { ifSuperInterfaces :: [Interface]
  32     }
  33
  34 type HierMap = (M.Map NativeWord Class)
  35 classHier :: IORef HierMap
  36 {-# NOINLINE classHier #-}
  37 classHier = unsafePerformIO $ newIORef M.empty
  38
  39 readHier :: IO HierMap
  40 readHier = readIORef classHier
  41
  42 writeHier :: HierMap -> IO ()
  43 writeHier = writeIORef classHier
  44
  45
  46 isInstanceOf :: NativeWord -> B.ByteString -> IO Bool
  47 isInstanceOf 0 _ = return False
  48 isInstanceOf obj classname = do
  49   obj_mtable <- peek (intPtrToPtr . fromIntegral $ obj)
  50   class_mtable <- getMethodTable classname
  51   ch <- readHier
  52   return $ checkInstance obj_mtable class_mtable ch
  53
  54 checkInstance :: NativeWord -> NativeWord -> HierMap -> Bool
  55 checkInstance obj cl_mtable ch
  56   | obj == cl_mtable = True
  57   | otherwise =
  58       case ch M.! obj of
  59         Class _ super _ -> checkInstance super cl_mtable ch
  60         JavaLangObject _ -> False
  61
  62 addClassEntry :: NativeWord -> NativeWord -> IO ()
  63 addClassEntry mtable 0 = do
  64   ch <- readHier
  65   writeHier (M.insert mtable (JavaLangObject mtable) ch)
  66 addClassEntry mtable super_mtable = do
  67   ch <- readHier
  68   when (not $ M.member super_mtable ch) $ error "classhierarchy: superclass should be in hierarchy!"
  69   let cl = Class mtable super_mtable []
  70   writeHier (M.insert mtable cl ch)