X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FTypes.hs;h=5e5bf221e0ba26420943967d2b77e2cdcedb7ab6;hb=c803146cc80b61305fde8279f0a36f8fe6ef7eb2;hp=521a269133c1383a754ec0a547233458c1dd372d;hpb=15833bb85e8b1b82f30024ff7261a208327ceb32;p=mate.git diff --git a/Mate/Types.hs b/Mate/Types.hs index 521a269..5e5bf22 100644 --- a/Mate/Types.hs +++ b/Mate/Types.hs @@ -1,135 +1,156 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} module Mate.Types where -import Data.Char -import Data.Word import Data.Int import qualified Data.Map as M import qualified Data.ByteString.Lazy as B -import Codec.Binary.UTF8.String hiding (encode,decode) -import Foreign.Ptr -import Foreign.StablePtr +import Data.IORef +import System.IO.Unsafe import JVM.ClassFile import JVM.Assembler +import Mate.NativeSizes + type BlockID = Int -- Represents a CFG node data BasicBlock = BasicBlock { - code :: [Instruction], - successor :: BBEnd } + code :: [Instruction], + successor :: BBEnd } -- describes (leaving) edges of a CFG node data BBEnd = Return | FallThrough BlockID | OneTarget BlockID | TwoTarget BlockID BlockID deriving Show type MapBB = M.Map BlockID BasicBlock +data RawMethod = RawMethod { + rawMapBB :: MapBB, + rawLocals :: Int, + rawStackSize :: Int, + rawArgCount :: NativeWord, + rawCodeLength :: NativeWord } + --- Word32 = point of method call in generated code +-- NativeWord = point of method call in generated code -- MethodInfo = relevant information about callee -type TMap = M.Map Word32 TrapInfo +type TrapMap = M.Map NativeWord TrapCause -data TrapInfo = MI MethodInfo | SFI StaticFieldInfo +data TrapCause = + StaticMethod MethodInfo | -- for static calls + VirtualCall Bool MethodInfo (IO NativeWord) | -- for invoke{interface,virtual} + InstanceOf B.ByteString | -- class name + NewObject B.ByteString | -- class name + StaticField StaticFieldInfo data StaticFieldInfo = StaticFieldInfo { sfiClassName :: B.ByteString, - sfiFieldName :: B.ByteString } - --- B.ByteString = name of method --- Word32 = entrypoint of method -type MMap = M.Map MethodInfo Word32 + sfiFieldName :: B.ByteString } deriving Show -type ClassMap = M.Map B.ByteString ClassInfo -type FieldMap = M.Map B.ByteString Int32 -data ClassInfo = ClassInfo { - clName :: B.ByteString, - clFile :: Class Resolved, - clStaticMap :: FieldMap, - clFieldMap :: FieldMap, - clMethodMap :: FieldMap, - clMethodBase :: Word32, - clInitDone :: Bool } +-- B.ByteString = name of method +-- NativeWord = entrypoint of method +type MethodMap = M.Map MethodInfo NativeWord data MethodInfo = MethodInfo { methName :: B.ByteString, - cName :: B.ByteString, - mSignature :: MethodSignature} - -instance Eq MethodInfo where - (MethodInfo m_a c_a s_a) == (MethodInfo m_b c_b s_b) = - (m_a == m_b) && (c_a == c_b) && (s_a == s_b) - --- TODO(bernhard): not really efficient. also, outsource that to hs-java -instance Ord MethodSignature where - compare (MethodSignature args_a ret_a) (MethodSignature args_b ret_b) - | cmp_args /= EQ = cmp_args - | otherwise = (show ret_a) `compare` (show ret_b) - where - cmp_args = (show args_a) `compare` (show args_b) - -instance Ord MethodInfo where - compare (MethodInfo m_a c_a s_a) (MethodInfo m_b c_b s_b) - | cmp_m /= EQ = cmp_m - | cmp_c /= EQ = cmp_c - | otherwise = s_a `compare` s_b - where - cmp_m = m_a `compare` m_b - cmp_c = c_a `compare` c_b + methClassName :: B.ByteString, + methSignature :: MethodSignature + } deriving (Eq, Ord) instance Show MethodInfo where show (MethodInfo method c sig) = - (toString c) ++ "." ++ (toString method) ++ "." ++ (show sig) + toString c ++ "." ++ toString method ++ "." ++ show sig + + + +-- store information of loaded classes +type ClassMap = M.Map B.ByteString ClassInfo + +data ClassInfo = ClassInfo { + ciName :: B.ByteString, + ciFile :: Class Direct, + ciStaticMap :: FieldMap, + ciFieldMap :: FieldMap, + ciMethodMap :: FieldMap, + ciMethodBase :: NativeWord, + ciInitDone :: Bool } + + +-- store field offsets in a map +type FieldMap = M.Map B.ByteString Int32 + + +-- java strings are allocated only once, therefore we +-- use a hashmap to store the address for a String +type StringMap = M.Map B.ByteString NativeWord + + +-- map "methodtable addr" to "classname" +-- we need that to identify the actual type +-- on the invokevirtual insn +type VirtualMap = M.Map NativeWord B.ByteString + + +-- store each parsed Interface upon first loading +type InterfaceMap = M.Map B.ByteString (Class Direct) + +-- store offset for each pair +type InterfaceMethodMap = M.Map B.ByteString NativeWord +{- toString :: B.ByteString -> String toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr +-} +-- better solutions for a global map hack are welcome! (typeclasses, TH, ...?) --- global map hax -foreign import ccall "get_trapmap" - get_trapmap :: IO (Ptr ()) +data MateCtx = MateCtx { + ctxMethodMap :: MethodMap, + ctxTrapMap :: TrapMap, + ctxClassMap :: ClassMap, + ctxVirtualMap :: VirtualMap, + ctxStringMap :: StringMap, + ctxInterfaceMap :: InterfaceMap, + ctxInterfaceMethodMap :: InterfaceMethodMap } -foreign import ccall "set_trapmap" - set_trapmap :: Ptr () -> IO () +emptyMateCtx :: MateCtx +emptyMateCtx = MateCtx M.empty M.empty M.empty M.empty M.empty M.empty M.empty -foreign import ccall "get_methodmap" - get_methodmap :: IO (Ptr ()) +mateCtx :: IORef MateCtx +{-# NOINLINE mateCtx #-} +mateCtx = unsafePerformIO $ newIORef emptyMateCtx -foreign import ccall "set_methodmap" - set_methodmap :: Ptr () -> IO () +-- TODO(bernhard): if we ever have thread support, don't forget MVars +#define SETMAP(name) set##name :: name -> IO (); \ + set##name m = do ctx <- readIORef mateCtx; \ + writeIORef mateCtx $ ctx { ctx##name = m }; -foreign import ccall "get_classmap" - get_classmap :: IO (Ptr ()) +#define GETMAP(name) get##name :: IO name ; \ + get##name = do ctx <- readIORef mateCtx; \ + return $ ctx##name ctx; -foreign import ccall "set_classmap" - set_classmap :: Ptr () -> IO () +SETMAP(MethodMap); +GETMAP(MethodMap) --- TODO(bernhard): make some typeclass magic 'n stuff -mmap2ptr :: MMap -> IO (Ptr ()) -mmap2ptr mmap = do - ptr_mmap <- newStablePtr mmap - return $ castStablePtrToPtr ptr_mmap +SETMAP(TrapMap) +GETMAP(TrapMap) -ptr2mmap :: Ptr () -> IO MMap -ptr2mmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr MMap) +SETMAP(ClassMap) +GETMAP(ClassMap) -tmap2ptr :: TMap -> IO (Ptr ()) -tmap2ptr tmap = do - ptr_tmap <- newStablePtr tmap - return $ castStablePtrToPtr ptr_tmap +SETMAP(VirtualMap) +GETMAP(VirtualMap) -ptr2tmap :: Ptr () -> IO TMap -ptr2tmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr tmap) +SETMAP(StringMap) +GETMAP(StringMap) -classmap2ptr :: ClassMap -> IO (Ptr ()) -classmap2ptr cmap = do - ptr_cmap <- newStablePtr cmap - return $ castStablePtrToPtr ptr_cmap +SETMAP(InterfaceMap) +GETMAP(InterfaceMap) -ptr2classmap :: Ptr () -> IO ClassMap -ptr2classmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap) +SETMAP(InterfaceMethodMap) +GETMAP(InterfaceMethodMap)