X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FTypes.hs;h=1f67aa6844cdedfeb69977f988407066af9c5dcb;hb=03ddf0056a8ebae7ce10d694bbf906c276677a33;hp=7f193251302a288c57d84fe967a4be606c29c60e;hpb=b25d636bdeaadc503cab14a9df7c1c8ec7b2c26c;p=mate.git diff --git a/Mate/Types.hs b/Mate/Types.hs index 7f19325..1f67aa6 100644 --- a/Mate/Types.hs +++ b/Mate/Types.hs @@ -1,16 +1,14 @@ {-# 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 @@ -19,158 +17,137 @@ import JVM.Assembler 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 :: Word32 } + -- Word32 = point of method call in generated code -- MethodInfo = relevant information about callee -type TMap = M.Map Word32 TrapInfo +type TrapMap = M.Map Word32 TrapCause -data TrapInfo = - MI MethodInfo | - VI MethodInfo | -- for virtual calls - SFI StaticFieldInfo +data TrapCause = + StaticMethod MethodInfo | -- for static calls + VirtualMethod Bool MethodInfo | -- for virtual calls + InterfaceMethod Bool MethodInfo | -- for interface calls + StaticField StaticFieldInfo deriving Show data StaticFieldInfo = StaticFieldInfo { sfiClassName :: B.ByteString, - sfiFieldName :: B.ByteString } + sfiFieldName :: B.ByteString } deriving Show + + -- B.ByteString = name of method -- Word32 = entrypoint of method -type MMap = M.Map MethodInfo Word32 +type MethodMap = M.Map MethodInfo Word32 + +data MethodInfo = MethodInfo { + methName :: B.ByteString, + methClassName :: B.ByteString, + methSignature :: MethodSignature + } deriving (Eq, Ord) +instance Show MethodInfo where + show (MethodInfo method c 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 :: Word32, + ciInitDone :: Bool } + + +-- store field offsets in a map type FieldMap = M.Map B.ByteString Int32 --- java strings are allocated once, therefore we + +-- 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 Word32 + -- map "methodtable addr" to "classname" -- we need that to identify the actual type -- on the invokevirtual insn type VirtualMap = M.Map Word32 B.ByteString -data ClassInfo = ClassInfo { - clName :: B.ByteString, - clFile :: Class Resolved, - clStaticMap :: FieldMap, - clFieldMap :: FieldMap, - clMethodMap :: FieldMap, - clMethodBase :: Word32, - clInitDone :: Bool } -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 +-- store each parsed Interface upon first loading +type InterfaceMap = M.Map B.ByteString (Class Direct) -instance Show MethodInfo where - show (MethodInfo method c sig) = - (toString c) ++ "." ++ (toString method) ++ "." ++ (show sig) +-- store offset for each pair +type InterfaceMethodMap = M.Map B.ByteString Word32 +{- 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 ()) - -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 () +data MateCtx = MateCtx { + ctxMethodMap :: MethodMap, + ctxTrapMap :: TrapMap, + ctxClassMap :: ClassMap, + ctxVirtualMap :: VirtualMap, + ctxStringMap :: StringMap, + ctxInterfaceMap :: InterfaceMap, + ctxInterfaceMethodMap :: InterfaceMethodMap } --- TODO(bernhard): make some typeclass magic 'n stuff -mmap2ptr :: MMap -> IO (Ptr ()) -mmap2ptr mmap = do - ptr_mmap <- newStablePtr mmap - return $ castStablePtrToPtr ptr_mmap +emptyMateCtx :: MateCtx +emptyMateCtx = MateCtx M.empty M.empty M.empty M.empty M.empty M.empty M.empty -ptr2mmap :: Ptr () -> IO MMap -ptr2mmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr MMap) +mateCtx :: IORef MateCtx +{-# NOINLINE mateCtx #-} +mateCtx = unsafePerformIO $ newIORef emptyMateCtx -tmap2ptr :: TMap -> IO (Ptr ()) -tmap2ptr tmap = do - ptr_tmap <- newStablePtr tmap - return $ castStablePtrToPtr ptr_tmap +-- 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 }; -ptr2tmap :: Ptr () -> IO TMap -ptr2tmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr tmap) +#define GETMAP(name) get##name :: IO name ; \ + get##name = do ctx <- readIORef mateCtx; \ + return $ ctx##name ctx; -classmap2ptr :: ClassMap -> IO (Ptr ()) -classmap2ptr cmap = do - ptr_cmap <- newStablePtr cmap - return $ castStablePtrToPtr ptr_cmap +SETMAP(MethodMap); +GETMAP(MethodMap) -ptr2classmap :: Ptr () -> IO ClassMap -ptr2classmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap) +SETMAP(TrapMap) +GETMAP(TrapMap) -virtualmap2ptr :: VirtualMap -> IO (Ptr ()) -virtualmap2ptr cmap = do - ptr_cmap <- newStablePtr cmap - return $ castStablePtrToPtr ptr_cmap +SETMAP(ClassMap) +GETMAP(ClassMap) -ptr2virtualmap :: Ptr () -> IO VirtualMap -ptr2virtualmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap) +SETMAP(VirtualMap) +GETMAP(VirtualMap) +SETMAP(StringMap) +GETMAP(StringMap) -stringsmap2ptr :: StringsMap -> IO (Ptr ()) -stringsmap2ptr cmap = do - ptr_cmap <- newStablePtr cmap - return $ castStablePtrToPtr ptr_cmap +SETMAP(InterfaceMap) +GETMAP(InterfaceMap) -ptr2stringsmap :: Ptr () -> IO StringsMap -ptr2stringsmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap) +SETMAP(InterfaceMethodMap) +GETMAP(InterfaceMethodMap)