X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FMethodPool.hs;h=d1df9cf1bb27fe95354b4a2a2daa72c7eab8081c;hb=HEAD;hp=e7a1aeb384ffa994ba2f8e7c168cddc47e10d98a;hpb=fdc2d9026667ed62abc086eac2049b79e19c9967;p=mate.git diff --git a/Mate/MethodPool.hs b/Mate/MethodPool.hs index e7a1aeb..d1df9cf 100644 --- a/Mate/MethodPool.hs +++ b/Mate/MethodPool.hs @@ -3,14 +3,17 @@ module Mate.MethodPool where import Data.Binary +import Data.String.Utils import qualified Data.Map as M +import qualified Data.Bimap as BI +import qualified Data.Set as S import qualified Data.ByteString.Lazy as B - -import Text.Printf +import System.Plugins +import Control.Monad import Foreign.Ptr import Foreign.C.Types -import Foreign.StablePtr +import Foreign.C.String import JVM.ClassFile @@ -18,101 +21,148 @@ import Harpy import Harpy.X86Disassembler import Mate.BasicBlocks -import Mate.X86CodeGen - - -foreign import ccall "get_mmap" - get_mmap :: IO (Ptr ()) +import Mate.Types +import Mate.NativeMachine +import Mate.ClassPool +import Mate.Debug +import Mate.Utilities +import Mate.Rts() -foreign import ccall "set_mmap" - set_mmap :: Ptr () -> IO () +foreign import ccall "dynamic" + code_void :: FunPtr (IO ()) -> IO () +foreign import ccall "&printMemoryUsage" + printMemoryUsageAddr :: FunPtr (IO ()) + +foreign import ccall "&loadLibrary" + loadLibraryAddr :: FunPtr (IO ()) --- B.ByteString = name of method --- Word32 = entrypoint of method -type MMap = M.Map B.ByteString Word32 +foreign import ccall "&printGCStats" + printGCStatsAddr :: FunPtr (IO ()) -foreign export ccall getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt -getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt -getMethodEntry signal_from ptr_mmap ptr_cmap = do - mmap <- ptr2mmap ptr_mmap - cmap <- ptr2cmap ptr_cmap +getMethodEntry :: MethodInfo -> IO (CPtrdiff, JpcNpcMap) +getMethodEntry mi@(MethodInfo method cm sig) = do + mmap <- getMethodMap - let w32_from = fromIntegral signal_from - let (method, cls, cpidx) = cmap M.! w32_from - case M.lookup method mmap of + (entryaddr, jnmap) <- case M.lookup mi mmap of Nothing -> do - printf "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show method) - -- TODO(bernhard): maybe we have to load the class first? - -- (Or better in X86CodeGen?) - let (CMethod _ nt) = (constsPool cls) M.! cpidx - hmap <- parseMethod cls (ntName nt) - printMapBB hmap - case hmap of - Just hmap' -> do - entry <- compileBB hmap' cls method - return $ fromIntegral $ ((fromIntegral $ ptrToIntPtr entry) :: Word32) - Nothing -> error $ (show method) ++ " not found. abort" - Just w32 -> return (fromIntegral w32) + cls <- getClassFile cm + printfMp $ printf "getMethodEntry: no method \"%s\" found. compile it\n" (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 + let scm = toString cm; smethod = toString method + if scm == "jmate/lang/MateRuntime" then + case smethod of + "loadLibrary" -> + return (funPtrToAddr loadLibraryAddr, BI.empty) + "printGCStats" -> + return (funPtrToAddr printGCStatsAddr, BI.empty) + "printMemoryUsage" -> + return (funPtrToAddr printMemoryUsageAddr, BI.empty) + _ -> + 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 + let nf' = (nf, BI.empty) + setMethodMap $ M.insert mi nf' mmap + return nf' + else do + rawmethod <- parseMethod cls' method sig + entry <- compileBB mi rawmethod (MethodInfo method (thisClass cls') sig) + addMethodRef entry mi clsnames + return entry + Nothing -> error $ show method ++ " not found. abort" + Just w32 -> return w32 + return (fromIntegral entryaddr, jnmap) + +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 = + case res of + Just x -> return $ Just (x, nextclsn, cls) + Nothing -> if thisname == "java/lang/Object" + then return Nothing + else do + supercl <- getClassFile (superClass cls) + lookupMethodRecursive name sig nextclsn supercl + where + 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 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 -- 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 -initMethodPool :: IO () -initMethodPool = do - mmap2ptr M.empty >>= set_mmap - cmap2ptr M.empty >>= set_cmap - -compileBB :: MapBB -> Class Resolved -> B.ByteString -> IO (Ptr Word8) -compileBB hmap cls name = do - mmap <- get_mmap >>= ptr2mmap - cmap <- get_cmap >>= ptr2cmap - - let ebb = emitFromBB cls hmap - (_, Right ((entry, _, _, new_cmap), disasm)) <- runCodeGen ebb () () - let w32_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32) - - let mmap' = M.insert name w32_entry mmap - let cmap' = M.union cmap new_cmap -- prefers elements in cmap - mmap2ptr mmap' >>= set_mmap - cmap2ptr cmap' >>= set_cmap - - printf "disasm:\n" - mapM_ (putStrLn . showAtt) disasm - -- UNCOMMENT NEXT LINE FOR GDB FUN - -- _ <- getLine - -- (1) start it with `gdb ./mate' and then `run ' - -- (2) on getLine, press ctrl+c +addMethodRef :: (NativeWord, JpcNpcMap) -> 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 :: MethodInfo -> RawMethod -> MethodInfo -> IO (NativeWord, JpcNpcMap) +compileBB mi rawmethod methodinfo = do + tmap <- getTrapMap + + cls <- getClassFile (methClassName methodinfo) + printfJit $ printf "emit code of \"%s\" from \"%s\":\n" (toString $ methName methodinfo) (toString $ methClassName methodinfo) + let ebb = emitFromBB cls mi rawmethod + let cgconfig = defaultCodeGenConfig { codeBufferSize = fromIntegral $ rawCodeLength rawmethod * 32 } + (jnmap, Right right) <- runCodeGenWithConfig ebb () BI.empty cgconfig + + let ((entry, _, new_tmap), _) = right + setTrapMap $ tmap `M.union` new_tmap -- prefers elements in tmap + + 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) + when mateDEBUG $ mapM_ (printfJit . printf "%s\n" . showIntel) (snd right) + 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 + -- else return "foo" + -- (1) build a debug build (see HACKING) and execute `make tests/Fib.gdb' + -- for example, where the suffix is important + -- (2) on getLine, press CTRL+C -- (3) `br *0x'; obtain the address from the disasm above -- (4) `cont' and press enter - return entry - - -foreign import ccall "dynamic" - code_void :: FunPtr (IO ()) -> (IO ()) - -executeFuncPtr :: Ptr Word8 -> IO () -executeFuncPtr entry = code_void $ ((castPtrToFunPtr entry) :: FunPtr (IO ())) - --- TODO(bernhard): make some typeclass magic 'n stuff -mmap2ptr :: MMap -> IO (Ptr ()) -mmap2ptr mmap = do - ptr_mmap <- newStablePtr mmap - return $ castStablePtrToPtr ptr_mmap - -ptr2mmap :: Ptr () -> IO MMap -ptr2mmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr MMap) + return (fromIntegral $ ptrToIntPtr entry, jnmap) -cmap2ptr :: CMap -> IO (Ptr ()) -cmap2ptr cmap = do - ptr_cmap <- newStablePtr cmap - return $ castStablePtrToPtr ptr_cmap -ptr2cmap :: Ptr () -> IO CMap -ptr2cmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap) +executeFuncPtr :: NativeWord -> IO () +executeFuncPtr entry = + code_void ((castPtrToFunPtr $ intPtrToPtr $ fromIntegral entry) :: FunPtr (IO ()))