Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
111 lines (95 sloc) 4.1 KB
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Compiler.Mate.Runtime.MethodPool
( lookupMethodEntry
, executeFuncPtr
) where
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as B
import Data.Binary
import Foreign
import Foreign.C.Types
import JVM.ClassFile
import Compiler.Mate.Debug
import Compiler.Mate.Types
import {-# SOURCE #-} Compiler.Mate.Pipeline
import Compiler.Mate.Backend.NativeSizes
import Compiler.Mate.Utilities
import Compiler.Mate.Runtime.ClassPool
import Compiler.Mate.Runtime.NativeMethods
foreign import ccall "dynamic"
code_void :: FunPtr (IO ()) -> IO ()
lookupMethodEntry:: MethodInfo -> IO CPtrdiff
lookupMethodEntry mi@(MethodInfo method cm sig) = do
mmap <- getMethodMap
case M.lookup mi mmap of
Nothing -> do
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'
nf <- if S.member ACC_NATIVE flags
then nativeAddr (toString cm) (toString method) (toString $ encode sig)
else do -- plain java method
entry <- compile $ MethodInfo method (thisClass cls') sig
insertCompiledMethod entry mi clsnames
return $ fromIntegral entry
setMethodMap $ M.insert mi nf mmap
return $ fromIntegral nf
Nothing -> error $ printf "\"%s\" not found. abort" (toString method)
Just w32 -> return $ fromIntegral w32
lookupMethodRecursive :: B.ByteString -> MethodSignature -> [B.ByteString] -> Class Direct
-> IO (Maybe (Method Direct, [B.ByteString], Class Direct))
lookupMethodRecursive name sig clsnames cls = do
printfCp $ printf "looking @ %s\n" (toString thisname)
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 = lookupMethodWithSig name sig cls
thisname = thisClass cls
nextclsn :: [B.ByteString]
nextclsn = thisname:clsnames
insertCompiledMethod :: NativeWord -> MethodInfo -> [B.ByteString] -> IO ()
insertCompiledMethod 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
compile :: MethodInfo -> IO NativeWord
compile methodinfo = time (printf "compile \"%s\"" $ toString $ methName methodinfo) $ do
tmap <- getTrapMap
cls <- getClassFile (methClassName methodinfo)
printfJit $ printf "emit code of \"%s\" from \"%s\":\n"
(toString $ methName methodinfo)
(toString $ methClassName methodinfo)
(entry, new_trapmap) <- compileMethod (methName methodinfo)
(methSignature methodinfo)
cls
setTrapMap $ tmap `M.union` new_trapmap -- prefers elements in tmap
printfJit $ printf "generated code of \"%s\" @ \"%s\" from \"%s\". DONE\n"
(toString $ methName methodinfo)
(show $ methSignature methodinfo)
(toString $ methClassName methodinfo)
-- 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<addr>'; obtain the address from the disasm above
-- (4) `cont' and press enter
return entry
executeFuncPtr :: NativeWord -> IO ()
executeFuncPtr entry =
code_void ((castPtrToFunPtr $ intPtrToPtr $ fromIntegral entry) :: FunPtr (IO ()))