module Mate.ClassHierarchy
( isInstanceOf
, addClassEntry
+ , addInterfaceEntry
) where
import qualified Data.Map as M
import qualified Data.ByteString.Lazy as B
-import Control.Applicative
+import Data.List
import Control.Monad
-import Text.Printf
-import Foreign
+import Foreign hiding (unsafePerformIO)
+import System.IO.Unsafe
import Data.IORef
import Mate.NativeSizes
data Class
- = Class
- { clMtable :: NativeWord
- , clSuperClass :: NativeWord
- , clInterfaces :: [Interface]
- }
+ = Class NativeWord [B.ByteString]
| JavaLangObject
- { clMtable :: NativeWord
- }
-data Interface
- = Interface
- { ifSuperInterfaces :: [Interface]
- }
-
-type HierMap = (M.Map NativeWord Class)
-classHier :: IORef HierMap
+type ClassHier = M.Map NativeWord Class
+classHier :: IORef ClassHier
{-# NOINLINE classHier #-}
classHier = unsafePerformIO $ newIORef M.empty
-readHier :: IO HierMap
-readHier = readIORef classHier
+type InterfaceHier = M.Map B.ByteString [B.ByteString]
+interfaceHier :: IORef InterfaceHier
+{-# NOINLINE interfaceHier #-}
+interfaceHier = unsafePerformIO $ newIORef M.empty
+
+readClass :: IO ClassHier
+readClass = readIORef classHier
+readInterface :: IO InterfaceHier
+readInterface = readIORef interfaceHier
-writeHier :: HierMap -> IO ()
-writeHier = writeIORef classHier
+writeClass :: ClassHier -> IO ()
+writeClass = writeIORef classHier
+writeInterface :: InterfaceHier -> IO ()
+writeInterface = writeIORef interfaceHier
isInstanceOf :: NativeWord -> B.ByteString -> IO Bool
isInstanceOf 0 _ = return False
isInstanceOf obj classname = do
obj_mtable <- peek (intPtrToPtr . fromIntegral $ obj)
- class_mtable <- getMethodTable classname
- ch <- readHier
- return $ checkInstance obj_mtable class_mtable ch
+ ch <- readClass
+ ih <- readInterface
+ if M.member classname ih
+ then do -- interface check
+ let ai = allInterfaces obj_mtable ch
+ return $ checkInterfaces ai classname ih
+ else do -- class check
+ class_mtable <- getMethodTable classname
+ return $ checkInstance obj_mtable class_mtable ch
+
+allInterfaces :: NativeWord -> ClassHier -> [B.ByteString]
+allInterfaces obj_mtable ch =
+ case ch M.! obj_mtable of
+ JavaLangObject -> []
+ Class superclass ifaces -> ifaces ++ allInterfaces superclass ch
-checkInstance :: NativeWord -> NativeWord -> HierMap -> Bool
+checkInterfaces :: [B.ByteString] -> B.ByteString -> InterfaceHier -> Bool
+checkInterfaces [] _ _ = False
+checkInterfaces ifaces target ih
+ | target `elem` ifaces = True
+ | otherwise = checkInterfaces (nextifaces \\ ifaces) target ih
+ where
+ nextifaces = concatMap (\x -> ih M.! x) ifaces
+
+checkInstance :: NativeWord -> NativeWord -> ClassHier -> Bool
checkInstance obj cl_mtable ch
| obj == cl_mtable = True
| otherwise =
case ch M.! obj of
- Class _ super _ -> checkInstance super cl_mtable ch
- JavaLangObject _ -> False
-
-addClassEntry :: NativeWord -> NativeWord -> IO ()
-addClassEntry mtable 0 = do
- ch <- readHier
- writeHier (M.insert mtable (JavaLangObject mtable) ch)
-addClassEntry mtable super_mtable = do
- ch <- readHier
- when (not $ M.member super_mtable ch) $ error "classhierarchy: superclass should be in hierarchy!"
- let cl = Class mtable super_mtable []
- writeHier (M.insert mtable cl ch)
+ Class super _ -> checkInstance super cl_mtable ch
+ JavaLangObject -> False
+
+addClassEntry :: NativeWord -> NativeWord -> [B.ByteString] -> IO ()
+addClassEntry mtable 0 _ = do
+ ch <- readClass
+ writeClass (M.insert mtable JavaLangObject ch)
+addClassEntry mtable super_mtable ifaces = do
+ ch <- readClass
+ unless (M.member super_mtable ch) $ error "classhierarchy: superclass should be in hierarchy!"
+ writeClass (M.insert mtable (Class super_mtable ifaces) ch)
+
+addInterfaceEntry :: B.ByteString -> [B.ByteString] -> IO ()
+addInterfaceEntry iface super_ifaces = do
+ ch <- readInterface
+ -- TODO: check super if's
+ writeInterface (M.insert iface super_ifaces ch)