X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FMethodPool.hs;h=c243d113950084fa56652f7b4950a64765c50797;hb=4c504fbb0b276782af6cd250e5e9fd4fdcc26967;hp=1d744932883ea84f69fd70ec38efff188322063e;hpb=aa51cc76fd6ab9e70ae0a0c2e722bdd9e0bd2c55;p=mate.git diff --git a/Mate/MethodPool.hs b/Mate/MethodPool.hs index 1d74493..c243d11 100644 --- a/Mate/MethodPool.hs +++ b/Mate/MethodPool.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ForeignFunctionInterface #-} +#include "debug.h" module Mate.MethodPool where import Data.Binary @@ -9,82 +11,105 @@ import qualified Data.Set as S import qualified Data.ByteString.Lazy as B import System.Plugins -import Text.Printf - import Foreign.Ptr import Foreign.C.Types import Foreign.C.String -import Foreign.StablePtr import JVM.ClassFile -import JVM.Converter import Harpy import Harpy.X86Disassembler +#ifdef DEBUG +import Text.Printf +#endif + import Mate.BasicBlocks import Mate.Types import Mate.X86CodeGen -import Mate.Utilities import Mate.ClassPool - +import Mate.Debug foreign import ccall "dynamic" - code_void :: FunPtr (IO ()) -> (IO ()) + code_void :: FunPtr (IO ()) -> IO () -foreign export ccall getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt -getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt -getMethodEntry signal_from ptr_mmap ptr_tmap = do - mmap <- ptr2mmap ptr_mmap - tmap <- ptr2tmap ptr_tmap +getMethodEntry :: CUInt -> CUInt -> IO CUInt +getMethodEntry signal_from methodtable = do + mmap <- getMethodMap + tmap <- getTrapMap + vmap <- getVirtualMap let w32_from = fromIntegral signal_from let mi = tmap M.! w32_from - case mi of - (MI mi'@(MethodInfo method cm sig)) -> do - case M.lookup mi' mmap of - Nothing -> do - cls <- getClassFile cm - printf "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show mi') - let mm = lookupMethod method cls - case mm of - Just mm' -> do - let flags = methodAccessFlags mm' - case S.member ACC_NATIVE flags of - False -> do - hmap <- parseMethod cls method - printMapBB hmap - case hmap of - Just hmap' -> do - entry <- compileBB hmap' mi' - return $ fromIntegral $ ((fromIntegral $ ptrToIntPtr entry) :: Word32) - Nothing -> error $ (show method) ++ " not found. abort" - True -> do - let symbol = (replace "/" "_" $ toString cm) ++ "__" ++ (toString method) ++ "__" ++ (replace "(" "_" (replace ")" "_" $ toString $ encode sig)) - printf "native-call: symbol: %s\n" symbol - nf <- loadNativeFunction symbol - let w32_nf = fromIntegral nf - let mmap' = M.insert mi' w32_nf mmap - mmap2ptr mmap' >>= set_methodmap - return nf - Nothing -> error $ (show method) ++ " not found. abort" - Just w32 -> return (fromIntegral w32) - _ -> error $ "getMethodEntry: no trapInfo. abort" + let mi'@(MethodInfo method cm sig) = + case mi of + (MI x) -> x + (VI (MethodInfo methname _ msig)) -> + MethodInfo methname (vmap M.! fromIntegral methodtable) msig + (II (MethodInfo methname _ msig)) -> + MethodInfo methname (vmap M.! fromIntegral methodtable) msig + _ -> error "getMethodEntry: no trapInfo. abort." + 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') + mm <- lookupMethodRecursive method [] 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 + let w32_nf = fromIntegral nf + setMethodMap $ M.insert mi' w32_nf mmap + return nf + else do + hmap <- parseMethod cls' method + 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" + Nothing -> error $ show method ++ " not found. abort" + Just w32 -> return (fromIntegral w32) + +lookupMethodRecursive :: B.ByteString -> [B.ByteString] -> Class Direct + -> IO (Maybe (Method Direct, [B.ByteString], Class Direct)) +lookupMethodRecursive name 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 nextclsn supercl + where + res = lookupMethod name 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 (CUInt) +loadNativeFunction :: String -> IO CUInt loadNativeFunction sym = do _ <- loadRawObject "ffi/native.o" -- TODO(bernhard): WTF resolveObjs (return ()) ptr <- withCString sym c_lookupSymbol - if (ptr == nullPtr) + if ptr == nullPtr then error $ "dyn. loading of \"" ++ sym ++ "\" failed." - else return $ fromIntegral $ minusPtr ptr nullPtr + else return $ fromIntegral $ ptrToIntPtr ptr -- t_01 :: IO () -- t_01 = do @@ -95,38 +120,36 @@ loadNativeFunction sym = do -- mmap2ptr mmap >>= set_mmap -- demo_mmap -- access Data.Map from C -initMethodPool :: IO () -initMethodPool = do - mmap2ptr M.empty >>= set_methodmap - tmap2ptr M.empty >>= set_trapmap - classmap2ptr M.empty >>= set_classmap +addMethodRef :: Word32 -> MethodInfo -> [B.ByteString] -> IO () +addMethodRef entry (MethodInfo mmname _ msig) clsnames = do + mmap <- getMethodMap + let newmap = M.fromList $ map (\x -> (MethodInfo mmname x msig, entry)) clsnames + setMethodMap $ mmap `M.union` newmap -compileBB :: MapBB -> MethodInfo -> IO (Ptr Word8) + +compileBB :: MapBB -> MethodInfo -> IO Word32 compileBB hmap methodinfo = do - mmap <- get_methodmap >>= ptr2mmap - tmap <- get_trapmap >>= ptr2tmap - - -- TODO(bernhard): replace parsing with some kind of classpool - cls <- getClassFile (cName methodinfo) - let ebb = emitFromBB cls hmap - (_, Right ((entry, _, _, new_tmap), disasm)) <- runCodeGen ebb () () - let w32_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32) - - let mmap' = M.insert methodinfo w32_entry mmap - let tmap' = M.union tmap new_tmap -- prefers elements in cmap - mmap2ptr mmap' >>= set_methodmap - tmap2ptr tmap' >>= set_trapmap - - printf "disasm:\n" - mapM_ (putStrLn . showAtt) disasm + tmap <- getTrapMap + + cls <- getClassFile (methClassName methodinfo) + let ebb = emitFromBB (methName methodinfo) cls hmap + (_, Right right) <- runCodeGen ebb () () + + let ((entry, _, _, new_tmap), _) = right + setTrapMap $ tmap `M.union` new_tmap -- prefers elements in tmap + + printfJit "generated code of \"%s\":\n" (toString $ methName methodinfo) + mapM_ (printfJit "%s\n" . showAtt) (snd right) + printfJit "\n\n" -- UNCOMMENT NEXT LINE FOR GDB FUN -- _ <- getLine -- (1) start it with `gdb ./mate' and then `run ' -- (2) on getLine, press ctrl+c -- (3) `br *0x'; obtain the address from the disasm above -- (4) `cont' and press enter - return entry + return $ fromIntegral $ ptrToIntPtr entry -executeFuncPtr :: Ptr Word8 -> IO () -executeFuncPtr entry = code_void $ ((castPtrToFunPtr entry) :: FunPtr (IO ())) +executeFuncPtr :: Word32 -> IO () +executeFuncPtr entry = + code_void ((castPtrToFunPtr $ intPtrToPtr $ fromIntegral entry) :: FunPtr (IO ()))