X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FTypes.hs;h=5e5bf221e0ba26420943967d2b77e2cdcedb7ab6;hb=c803146cc80b61305fde8279f0a36f8fe6ef7eb2;hp=2c181b07bc186dac9b118a9edd90b22b6a19f313;hpb=b3427c38e5e0b38e44df820e03cabf91613be1ce;p=mate.git diff --git a/Mate/Types.hs b/Mate/Types.hs index 2c181b0..5e5bf22 100644 --- a/Mate/Types.hs +++ b/Mate/Types.hs @@ -1,20 +1,19 @@ {-# 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 @@ -27,17 +26,24 @@ data BBEnd = Return | FallThrough BlockID | OneTarget BlockID | TwoTarget BlockI 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 TrapMap = M.Map Word32 TrapInfo +type TrapMap = M.Map NativeWord TrapCause -data TrapInfo = - MI MethodInfo | -- for static calls - VI MethodInfo | -- for virtual calls - II MethodInfo | -- for interface calls - SFI StaticFieldInfo deriving Show +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, @@ -46,8 +52,8 @@ data StaticFieldInfo = StaticFieldInfo { -- B.ByteString = name of method --- Word32 = entrypoint of method -type MethodMap = M.Map MethodInfo Word32 +-- NativeWord = entrypoint of method +type MethodMap = M.Map MethodInfo NativeWord data MethodInfo = MethodInfo { methName :: B.ByteString, @@ -55,14 +61,6 @@ data MethodInfo = MethodInfo { methSignature :: MethodSignature } deriving (Eq, Ord) --- TODO(bernhard): not really efficient. also, outsource that to hs-java --- deriving should be enough? -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 Show MethodInfo where show (MethodInfo method c sig) = toString c ++ "." ++ toString method ++ "." ++ show sig @@ -74,11 +72,11 @@ type ClassMap = M.Map B.ByteString ClassInfo data ClassInfo = ClassInfo { ciName :: B.ByteString, - ciFile :: Class Resolved, + ciFile :: Class Direct, ciStaticMap :: FieldMap, ciFieldMap :: FieldMap, ciMethodMap :: FieldMap, - ciMethodBase :: Word32, + ciMethodBase :: NativeWord, ciInitDone :: Bool } @@ -88,127 +86,71 @@ 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 StringsMap = M.Map B.ByteString Word32 +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 Word32 B.ByteString +type VirtualMap = M.Map NativeWord B.ByteString -- store each parsed Interface upon first loading -type InterfacesMap = M.Map B.ByteString (Class Resolved) +type InterfaceMap = M.Map B.ByteString (Class Direct) -- store offset for each pair -type InterfaceMethodMap = M.Map B.ByteString Word32 +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, ...?) --- those functions are for the "global map hax" --- TODO(bernhard): other solution please -foreign import ccall "get_trapmap" - get_trapmap :: IO (Ptr ()) - -foreign import ccall "set_trapmap" - set_trapmap :: Ptr () -> IO () - -foreign import ccall "get_methodmap" - get_methodmap :: IO (Ptr ()) - -foreign import ccall "set_methodmap" - set_methodmap :: Ptr () -> IO () - -foreign import ccall "get_classmap" - get_classmap :: IO (Ptr ()) - -foreign import ccall "set_classmap" - set_classmap :: Ptr () -> IO () - -foreign import ccall "get_virtualmap" - get_virtualmap :: IO (Ptr ()) - -foreign import ccall "set_virtualmap" - set_virtualmap :: Ptr () -> IO () - -foreign import ccall "get_stringsmap" - get_stringsmap :: IO (Ptr ()) - -foreign import ccall "set_stringsmap" - set_stringsmap :: Ptr () -> IO () - -foreign import ccall "get_interfacesmap" - get_interfacesmap :: IO (Ptr ()) - -foreign import ccall "set_interfacesmap" - set_interfacesmap :: Ptr () -> IO () - -foreign import ccall "get_interfacemethodmap" - get_interfacemethodmap :: IO (Ptr ()) - -foreign import ccall "set_interfacemethodmap" - set_interfacemethodmap :: Ptr () -> IO () - --- TODO(bernhard): make some typeclass magic 'n stuff --- or remove that sh** -methodmap2ptr :: MethodMap -> IO (Ptr ()) -methodmap2ptr methodmap = do - ptr_methodmap <- newStablePtr methodmap - return $ castStablePtrToPtr ptr_methodmap - -ptr2methodmap :: Ptr () -> IO MethodMap -ptr2methodmap methodmap = deRefStablePtr (castPtrToStablePtr methodmap :: StablePtr MethodMap) - -trapmap2ptr :: TrapMap -> IO (Ptr ()) -trapmap2ptr trapmap = do - ptr_trapmap <- newStablePtr trapmap - return $ castStablePtrToPtr ptr_trapmap - -ptr2trapmap :: Ptr () -> IO TrapMap -ptr2trapmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr trapmap) - -classmap2ptr :: ClassMap -> IO (Ptr ()) -classmap2ptr cmap = do - ptr_cmap <- newStablePtr cmap - return $ castStablePtrToPtr ptr_cmap - -ptr2classmap :: Ptr () -> IO ClassMap -ptr2classmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap) +data MateCtx = MateCtx { + ctxMethodMap :: MethodMap, + ctxTrapMap :: TrapMap, + ctxClassMap :: ClassMap, + ctxVirtualMap :: VirtualMap, + ctxStringMap :: StringMap, + ctxInterfaceMap :: InterfaceMap, + ctxInterfaceMethodMap :: InterfaceMethodMap } -virtualmap2ptr :: VirtualMap -> IO (Ptr ()) -virtualmap2ptr cmap = do - ptr_cmap <- newStablePtr cmap - return $ castStablePtrToPtr ptr_cmap +emptyMateCtx :: MateCtx +emptyMateCtx = MateCtx M.empty M.empty M.empty M.empty M.empty M.empty M.empty -ptr2virtualmap :: Ptr () -> IO VirtualMap -ptr2virtualmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap) +mateCtx :: IORef MateCtx +{-# NOINLINE mateCtx #-} +mateCtx = unsafePerformIO $ newIORef emptyMateCtx +-- 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 }; -stringsmap2ptr :: StringsMap -> IO (Ptr ()) -stringsmap2ptr cmap = do - ptr_cmap <- newStablePtr cmap - return $ castStablePtrToPtr ptr_cmap +#define GETMAP(name) get##name :: IO name ; \ + get##name = do ctx <- readIORef mateCtx; \ + return $ ctx##name ctx; -ptr2stringsmap :: Ptr () -> IO StringsMap -ptr2stringsmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap) +SETMAP(MethodMap); +GETMAP(MethodMap) +SETMAP(TrapMap) +GETMAP(TrapMap) -interfacesmap2ptr :: InterfacesMap -> IO (Ptr ()) -interfacesmap2ptr cmap = do - ptr_cmap <- newStablePtr cmap - return $ castStablePtrToPtr ptr_cmap +SETMAP(ClassMap) +GETMAP(ClassMap) -ptr2interfacesmap :: Ptr () -> IO InterfacesMap -ptr2interfacesmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap) +SETMAP(VirtualMap) +GETMAP(VirtualMap) +SETMAP(StringMap) +GETMAP(StringMap) -interfacemethodmap2ptr :: InterfaceMethodMap -> IO (Ptr ()) -interfacemethodmap2ptr cmap = do - ptr_cmap <- newStablePtr cmap - return $ castStablePtrToPtr ptr_cmap +SETMAP(InterfaceMap) +GETMAP(InterfaceMap) -ptr2interfacemethodmap :: Ptr () -> IO InterfaceMethodMap -ptr2interfacemethodmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap) +SETMAP(InterfaceMethodMap) +GETMAP(InterfaceMethodMap)