X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FMethodPool.hs;h=4a7cf7e384929223061888580ea70a877aac3840;hb=e233bbb3bd29c6665239c7a9139826ce21913d29;hp=7f0779c2627e1b905c0bf159b626a553f6e2424a;hpb=f82dbecc763818452667ac568da96b7c5dd7cc97;p=mate.git diff --git a/Mate/MethodPool.hs b/Mate/MethodPool.hs index 7f0779c..4a7cf7e 100644 --- a/Mate/MethodPool.hs +++ b/Mate/MethodPool.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ForeignFunctionInterface #-} -#include "debug.h" module Mate.MethodPool where import Data.Binary @@ -20,22 +18,27 @@ import JVM.ClassFile import Harpy import Harpy.X86Disassembler -#ifdef DEBUG -import Text.Printf -#endif - import Mate.BasicBlocks import Mate.Types -import Mate.X86CodeGen +import Mate.NativeMachine import Mate.ClassPool import Mate.Debug import Mate.Utilities +import Mate.Rts() foreign import ccall "dynamic" code_void :: FunPtr (IO ()) -> IO () +foreign import ccall "&printMemoryUsage" + printMemoryUsageAddr :: FunPtr (IO ()) + +foreign import ccall "&loadLibrary" + loadLibraryAddr :: FunPtr (IO ()) + +foreign import ccall "&printGCStats" + printGCStatsAddr :: FunPtr (IO ()) -getMethodEntry :: CUInt -> CUInt -> IO CUInt +getMethodEntry :: CPtrdiff -> CPtrdiff -> IO CPtrdiff getMethodEntry signal_from methodtable = do mmap <- getMethodMap tmap <- getTrapMap @@ -44,47 +47,54 @@ getMethodEntry signal_from methodtable = do let w32_from = fromIntegral signal_from let mi = tmap M.! w32_from let mi'@(MethodInfo method cm sig) = - case mi of - (StaticMethod x) -> x - (VirtualMethod _ (MethodInfo methname _ msig)) -> newMi methname msig - (InterfaceMethod _ (MethodInfo methname _ msig)) -> newMi methname msig - _ -> error "getMethodEntry: no TrapCause found. abort." - where newMi mn = MethodInfo mn (vmap M.! fromIntegral methodtable) - -- bernhard (TODO): doesn't work with gnu classpath at some point. didn't - -- figured out the problem yet :/ therefore, I have no - -- testcase for replaying the situation. - -- setTrapMap $ M.delete w32_from tmap + case mi of + (StaticMethod x) -> x + (VirtualCall _ (MethodInfo methname _ msig) _) -> newMi methname msig + _ -> error "getMethodEntry: no TrapCause found. abort." + where newMi mn = MethodInfo mn (vmap M.! fromIntegral methodtable) entryaddr <- case M.lookup mi' mmap of Nothing -> do cls <- getClassFile cm - printfMp "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show mi') + printfMp $ printf "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show mi') mm <- lookupMethodRecursive method sig [] cls case mm of Just (mm', clsnames, cls') -> do let flags = methodAccessFlags mm' if S.member ACC_NATIVE flags then do - -- TODO(bernhard): cleaner please... *do'h* - let sym1 = replace "/" "_" $ toString cm - parenth = replace "(" "_" $ replace ")" "_" $ toString $ encode sig - sym2 = replace ";" "_" $ replace "/" "_" parenth - symbol = sym1 ++ "__" ++ toString method ++ "__" ++ sym2 - printfMp "native-call: symbol: %s\n" symbol - nf <- loadNativeFunction symbol - setMethodMap $ M.insert mi' nf mmap - return nf + let scm = toString cm; smethod = toString method + if scm == "jmate/lang/MateRuntime" then do + case smethod of + "loadLibrary" -> + return . funPtrToAddr $ loadLibraryAddr + "printGCStats" -> + return . funPtrToAddr $ printGCStatsAddr + "printMemoryUsage" -> + return . funPtrToAddr $ printMemoryUsageAddr + _ -> + error $ "native-call: " ++ smethod ++ " not found." + else do + -- TODO(bernhard): cleaner please... *do'h* + let sym1 = replace "/" "_" scm + parenth = replace "(" "_" $ replace ")" "_" $ toString $ encode sig + sym2 = replace ";" "_" $ replace "/" "_" parenth + symbol = sym1 ++ "__" ++ smethod ++ "__" ++ sym2 + printfMp $ printf "native-call: symbol: %s\n" symbol + nf <- loadNativeFunction symbol + setMethodMap $ M.insert mi' nf mmap + return nf else do - hmap <- parseMethod cls' method sig - case hmap of - Just hmap' -> do - entry <- compileBB hmap' (MethodInfo method (thisClass cls') sig) - addMethodRef entry mi' clsnames - return $ fromIntegral entry - Nothing -> error $ show method ++ " not found. abort" + rawmethod <- parseMethod cls' method sig + entry <- compileBB rawmethod (MethodInfo method (thisClass cls') sig) + addMethodRef entry mi' clsnames + return $ fromIntegral entry Nothing -> error $ show method ++ " not found. abort" Just w32 -> return w32 return $ fromIntegral entryaddr +funPtrToAddr :: Num b => FunPtr a -> b +funPtrToAddr = fromIntegral . ptrToIntPtr . castFunPtrToPtr + lookupMethodRecursive :: B.ByteString -> MethodSignature -> [B.ByteString] -> Class Direct -> IO (Maybe (Method Direct, [B.ByteString], Class Direct)) lookupMethodRecursive name sig clsnames cls = @@ -96,55 +106,59 @@ lookupMethodRecursive name sig clsnames cls = supercl <- getClassFile (superClass cls) lookupMethodRecursive name sig nextclsn supercl where - res = lookupMethodSig name sig cls - thisname = thisClass cls - nextclsn :: [B.ByteString] - nextclsn = thisname:clsnames + res = lookupMethodSig name sig cls + thisname = thisClass cls + nextclsn :: [B.ByteString] + nextclsn = thisname:clsnames -- TODO(bernhard): UBERHAX. ghc patch? foreign import ccall safe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a) -loadNativeFunction :: String -> IO Word32 +loadNativeFunction :: String -> IO NativeWord loadNativeFunction sym = do - _ <- loadRawObject "ffi/native.o" - -- TODO(bernhard): WTF - resolveObjs (return ()) - ptr <- withCString sym c_lookupSymbol - if ptr == nullPtr - then error $ "dyn. loading of \"" ++ sym ++ "\" failed." - else return $ fromIntegral $ ptrToIntPtr ptr + _ <- loadRawObject "ffi/native.o" + -- TODO(bernhard): WTF + resolveObjs (return ()) + ptr <- withCString sym c_lookupSymbol + if ptr == nullPtr + then error $ "dyn. loading of \"" ++ sym ++ "\" failed." + else return $ fromIntegral $ ptrToIntPtr ptr -- t_01 :: IO () -- t_01 = do -- (entry, _) <- testCase "./tests/Fib.class" "fib" --- let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32) +-- let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: NativeWord) -- let mmap = M.insert ("fib" :: String) int_entry M.empty -- mapM_ (\(x,y) -> printf "%s at 0x%08x\n" x y) $ M.toList mmap -- mmap2ptr mmap >>= set_mmap -- demo_mmap -- access Data.Map from C -addMethodRef :: Word32 -> MethodInfo -> [B.ByteString] -> IO () +addMethodRef :: NativeWord -> MethodInfo -> [B.ByteString] -> IO () addMethodRef entry (MethodInfo mmname _ msig) clsnames = do mmap <- getMethodMap let newmap = foldr (\i -> M.insert (MethodInfo mmname i msig) entry) M.empty clsnames setMethodMap $ mmap `M.union` newmap -compileBB :: MapBB -> MethodInfo -> IO Word32 -compileBB hmap methodinfo = do +compileBB :: RawMethod -> MethodInfo -> IO NativeWord +compileBB rawmethod methodinfo = do tmap <- getTrapMap cls <- getClassFile (methClassName methodinfo) - let ebb = emitFromBB (methName methodinfo) (methSignature methodinfo) cls hmap - (_, Right right) <- runCodeGen ebb () () + let ebb = emitFromBB cls rawmethod + let cgconfig = defaultCodeGenConfig { codeBufferSize = fromIntegral $ (rawCodeLength rawmethod) * 32 } + (_, Right right) <- runCodeGenWithConfig ebb () () cgconfig let ((entry, _, _, new_tmap), _) = right setTrapMap $ tmap `M.union` new_tmap -- prefers elements in tmap - printfJit "generated code of \"%s\" from \"%s\":\n" (toString $ methName methodinfo) (toString $ methClassName methodinfo) - mapM_ (printfJit "%s\n" . showAtt) (snd right) - printfJit "\n\n" + printfJit $ printf "generated code of \"%s\" from \"%s\":\n" (toString $ methName methodinfo) (toString $ methClassName methodinfo) + printfJit $ printf "\tstacksize: 0x%04x, locals: 0x%04x\n" (rawStackSize rawmethod) (rawLocals rawmethod) + if mateDEBUG + then mapM_ (printfJit . printf "%s\n" . showAtt) (snd right) + else return () + printfJit $ printf "\n\n" -- UNCOMMENT NEXT LINES FOR GDB FUN -- if (toString $ methName methodinfo) == "thejavamethodIwant2debug" -- then putStrLn "press CTRL+C now for setting a breakpoint. then `c' and ENTER for continue" >> getLine @@ -157,6 +171,6 @@ compileBB hmap methodinfo = do return $ fromIntegral $ ptrToIntPtr entry -executeFuncPtr :: Word32 -> IO () +executeFuncPtr :: NativeWord -> IO () executeFuncPtr entry = code_void ((castPtrToFunPtr $ intPtrToPtr $ fromIntegral entry) :: FunPtr (IO ()))