X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FMethodPool.hs;h=1403eaea045745436919ce5c90755c0bd283722c;hb=8cce0bebc102531155bece6f56200cb7cf12d976;hp=672c70cdf371ba97e99dd296219f63c53d6812ae;hpb=b3427c38e5e0b38e44df820e03cabf91613be1ce;p=mate.git diff --git a/Mate/MethodPool.hs b/Mate/MethodPool.hs index 672c70c..1403eae 100644 --- a/Mate/MethodPool.hs +++ b/Mate/MethodPool.hs @@ -27,51 +27,38 @@ import Text.Printf import Mate.BasicBlocks import Mate.Types import Mate.X86CodeGen -import Mate.Utilities import Mate.ClassPool import Mate.Debug +import Mate.Utilities foreign import ccall "dynamic" code_void :: FunPtr (IO ()) -> IO () -foreign export ccall getTrapType :: CUInt -> CUInt -> IO CUInt -getTrapType :: CUInt -> CUInt -> IO CUInt -getTrapType signal_from from2 = do - tmap <- get_trapmap >>= ptr2trapmap - case M.lookup (fromIntegral signal_from) tmap of - (Just (MI _)) -> return 0 - (Just (VI _)) -> return 1 - (Just (SFI _)) -> return 2 - (Just (II _)) -> return 4 - -- maybe we've a hit on the second `from' value - Nothing -> case M.lookup (fromIntegral from2) tmap of - (Just (VI _)) -> return 1 - (Just (II _)) -> return 4 - (Just _) -> error "getTrapType: abort #1 :-(" - Nothing -> error "getTrapType: abort #2 :-(" - -foreign export ccall getMethodEntry :: CUInt -> CUInt -> IO CUInt + getMethodEntry :: CUInt -> CUInt -> IO CUInt getMethodEntry signal_from methodtable = do - mmap <- get_methodmap >>= ptr2methodmap - tmap <- get_trapmap >>= ptr2trapmap - vmap <- get_virtualmap >>= ptr2virtualmap + mmap <- getMethodMap + tmap <- getTrapMap + vmap <- getVirtualMap let w32_from = fromIntegral signal_from let mi = tmap M.! w32_from 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." + (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 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 + mm <- lookupMethodRecursive method sig [] cls case mm of Just (mm', clsnames, cls') -> do let flags = methodAccessFlags mm' @@ -85,11 +72,10 @@ getMethodEntry signal_from methodtable = do printfMp "native-call: symbol: %s\n" symbol nf <- loadNativeFunction symbol let w32_nf = fromIntegral nf - let mmap' = M.insert mi' w32_nf mmap - methodmap2ptr mmap' >>= set_methodmap + setMethodMap $ M.insert mi' w32_nf mmap return nf else do - hmap <- parseMethod cls' method + hmap <- parseMethod cls' method sig case hmap of Just hmap' -> do entry <- compileBB hmap' (MethodInfo method (thisClass cls') sig) @@ -99,18 +85,18 @@ getMethodEntry signal_from methodtable = do Nothing -> error $ show method ++ " not found. abort" Just w32 -> return (fromIntegral w32) -lookupMethodRecursive :: B.ByteString -> [B.ByteString] -> Class Resolved - -> IO (Maybe (Method Resolved, [B.ByteString], Class Resolved)) -lookupMethodRecursive name clsnames cls = +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 nextclsn supercl + lookupMethodRecursive name sig nextclsn supercl where - res = lookupMethod name cls + res = lookupMethodSig name sig cls thisname = thisClass cls nextclsn :: [B.ByteString] nextclsn = thisname:clsnames @@ -138,43 +124,34 @@ loadNativeFunction sym = do -- mmap2ptr mmap >>= set_mmap -- demo_mmap -- access Data.Map from C -initMethodPool :: IO () -initMethodPool = do - methodmap2ptr M.empty >>= set_methodmap - trapmap2ptr M.empty >>= set_trapmap - classmap2ptr M.empty >>= set_classmap - virtualmap2ptr M.empty >>= set_virtualmap - stringsmap2ptr M.empty >>= set_stringsmap - interfacesmap2ptr M.empty >>= set_interfacesmap - interfacemethodmap2ptr M.empty >>= set_interfacemethodmap - - addMethodRef :: Word32 -> MethodInfo -> [B.ByteString] -> IO () addMethodRef entry (MethodInfo mmname _ msig) clsnames = do - mmap <- get_methodmap >>= ptr2methodmap + mmap <- getMethodMap let newmap = M.fromList $ map (\x -> (MethodInfo mmname x msig, entry)) clsnames - methodmap2ptr (mmap `M.union` newmap) >>= set_methodmap + setMethodMap $ mmap `M.union` newmap compileBB :: MapBB -> MethodInfo -> IO Word32 compileBB hmap methodinfo = do - tmap <- get_trapmap >>= ptr2trapmap + tmap <- getTrapMap cls <- getClassFile (methClassName methodinfo) - let ebb = emitFromBB (methName methodinfo) cls hmap + let ebb = emitFromBB (methName methodinfo) (methSignature methodinfo) cls hmap (_, Right right) <- runCodeGen ebb () () let ((entry, _, _, new_tmap), _) = right - let tmap' = tmap `M.union` new_tmap -- prefers elements in tmap - trapmap2ptr tmap' >>= set_trapmap + setTrapMap $ tmap `M.union` new_tmap -- prefers elements in tmap - printfJit "generated code of \"%s\":\n" (toString $ methName methodinfo) + printfJit "generated code of \"%s\" from \"%s\":\n" (toString $ methName methodinfo) (toString $ methClassName 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 + -- 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 $ fromIntegral $ ptrToIntPtr entry