Mate/ClassHierarchy.hs

   1 module Mate.ClassHierarchy
   2   ( isInstanceOf
   3   , addClassEntry
   4   , addInterfaceEntry
   5   ) where
   6
   7 import qualified Data.Map as M
   8 import qualified Data.ByteString.Lazy as B
   9 import Data.List
  10 import Control.Monad
  11
  12 import Foreign hiding (unsafePerformIO)
  13 import System.IO.Unsafe
  14 import Data.IORef
  15
  16 import Mate.NativeSizes
  17 import Mate.ClassPool
  18
  19
  20 data Class
  21   = Class NativeWord [B.ByteString]
  22   | JavaLangObject
  23
  24 type ClassHier = M.Map NativeWord Class
  25 classHier :: IORef ClassHier
  26 {-# NOINLINE classHier #-}
  27 classHier = unsafePerformIO $ newIORef M.empty
  28
  29 type InterfaceHier = M.Map B.ByteString [B.ByteString]
  30 interfaceHier :: IORef InterfaceHier
  31 {-# NOINLINE interfaceHier #-}
  32 interfaceHier = unsafePerformIO $ newIORef M.empty
  33
  34 readClass :: IO ClassHier
  35 readClass = readIORef classHier
  36 readInterface :: IO InterfaceHier
  37 readInterface = readIORef interfaceHier
  38
  39 writeClass :: ClassHier -> IO ()
  40 writeClass = writeIORef classHier
  41 writeInterface :: InterfaceHier -> IO ()
  42 writeInterface = writeIORef interfaceHier
  43
  44
  45 isInstanceOf :: NativeWord -> B.ByteString -> IO Bool
  46 isInstanceOf 0 _ = return False
  47 isInstanceOf obj classname = do
  48   obj_mtable <- peek (intPtrToPtr . fromIntegral $ obj)
  49   ch <- readClass
  50   ih <- readInterface
  51   if M.member classname ih
  52     then do -- interface check
  53       let ai = allInterfaces obj_mtable ch
  54       return $ checkInterfaces ai classname ih
  55     else do -- class check
  56       class_mtable <- getMethodTable classname
  57       return $ checkInstance obj_mtable class_mtable ch
  58
  59 allInterfaces :: NativeWord -> ClassHier -> [B.ByteString]
  60 allInterfaces obj_mtable ch =
  61   case ch M.! obj_mtable of
  62     JavaLangObject -> []
  63     Class superclass ifaces -> ifaces ++ allInterfaces superclass ch
  64
  65 checkInterfaces :: [B.ByteString] -> B.ByteString -> InterfaceHier -> Bool
  66 checkInterfaces [] _ _ = False
  67 checkInterfaces ifaces target ih
  68   | target `elem` ifaces = True
  69   | otherwise = checkInterfaces (nextifaces \\ ifaces) target ih
  70     where
  71       nextifaces = concatMap (\x -> ih M.! x) ifaces
  72
  73 checkInstance :: NativeWord -> NativeWord -> ClassHier -> Bool
  74 checkInstance obj cl_mtable ch
  75   | obj == cl_mtable = True
  76   | otherwise =
  77       case ch M.! obj of
  78         Class super _ -> checkInstance super cl_mtable ch
  79         JavaLangObject -> False
  80
  81 addClassEntry :: NativeWord -> NativeWord -> [B.ByteString] -> IO ()
  82 addClassEntry mtable 0 _ = do
  83   ch <- readClass
  84   writeClass (M.insert mtable JavaLangObject ch)
  85 addClassEntry mtable super_mtable ifaces = do
  86   ch <- readClass
  87   unless (M.member super_mtable ch) $ error "classhierarchy: superclass should be in hierarchy!"
  88   writeClass (M.insert mtable (Class super_mtable ifaces) ch)
  89
  90 addInterfaceEntry :: B.ByteString -> [B.ByteString] -> IO ()
  91 addInterfaceEntry iface super_ifaces = do
  92   ch <- readInterface
  93   -- TODO: check super if's
  94   writeInterface (M.insert iface super_ifaces ch)