Mate/MethodPool.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE ForeignFunctionInterface #-}
   4 #include "debug.h"
   5 module Mate.MethodPool where
   6
   7 import Data.Binary
   8 import Data.String.Utils
   9 import qualified Data.Map as M
  10 import qualified Data.Set as S
  11 import qualified Data.ByteString.Lazy as B
  12 import System.Plugins
  13
  14 import Foreign.Ptr
  15 import Foreign.C.Types
  16 import Foreign.C.String
  17
  18 import JVM.ClassFile
  19
  20 import Harpy
  21 #ifdef DBG_JIT
  22 import Harpy.X86Disassembler
  23 #endif
  24
  25 #ifdef DEBUG
  26 import Text.Printf
  27 #endif
  28
  29 import Mate.BasicBlocks
  30 import Mate.Types
  31 import Mate.NativeMachine
  32 import Mate.ClassPool
  33 import Mate.Debug
  34 import Mate.Utilities
  35 import Mate.Rts()
  36
  37 foreign import ccall "dynamic"
  38    code_void :: FunPtr (IO ()) -> IO ()
  39
  40 foreign import ccall "&demoInterfaceCall"
  41   demoInterfaceCallAddr :: FunPtr (CUInt -> IO ())
  42
  43 foreign import ccall "&printMemoryUsage"
  44   printMemoryUsageAddr :: FunPtr (IO ())
  45
  46 foreign import ccall "&loadLibrary"
  47   loadLibraryAddr :: FunPtr (IO ())
  48
  49 getMethodEntry :: CPtrdiff -> CPtrdiff -> IO CPtrdiff
  50 getMethodEntry signal_from methodtable = do
  51   mmap <- getMethodMap
  52   tmap <- getTrapMap
  53   vmap <- getVirtualMap
  54
  55   let w32_from = fromIntegral signal_from
  56   let mi = tmap M.! w32_from
  57   let mi'@(MethodInfo method cm sig) =
  58        case mi of
  59          (StaticMethod x) -> x
  60          (VirtualCall _ (MethodInfo methname _ msig) _) -> newMi methname msig
  61          _ -> error "getMethodEntry: no TrapCause found. abort."
  62        where newMi mn = MethodInfo mn (vmap M.! fromIntegral methodtable)
  63   -- bernhard (TODO): doesn't work with gnu classpath at some point. didn't
  64   --                  figured out the problem yet :/ therefore, I have no
  65   --                  testcase for replaying the situation.
  66   -- setTrapMap $ M.delete w32_from tmap
  67   entryaddr <- case M.lookup mi' mmap of
  68     Nothing -> do
  69       cls <- getClassFile cm
  70       printfMp "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show mi')
  71       mm <- lookupMethodRecursive method sig [] cls
  72       case mm of
  73         Just (mm', clsnames, cls') -> do
  74             let flags = methodAccessFlags mm'
  75             if S.member ACC_NATIVE flags
  76               then do
  77                 let scm = toString cm; smethod = toString method
  78                 if scm == "jmate/lang/MateRuntime" then do
  79                   case smethod of
  80                     "loadLibrary" ->
  81                        return . funPtrToAddr $ loadLibraryAddr
  82                     "demoInterfaceCall" ->
  83                        return . funPtrToAddr $ demoInterfaceCallAddr
  84                     "printMemoryUsage" ->
  85                        return . funPtrToAddr $ printMemoryUsageAddr
  86                     _ ->
  87                        error $ "native-call: " ++ smethod ++ " not found."
  88                 else do
  89                   -- TODO(bernhard): cleaner please... *do'h*
  90                   let sym1 = replace "/" "_" scm
  91                       parenth = replace "(" "_" $ replace ")" "_" $ toString $ encode sig
  92                       sym2 = replace ";" "_" $ replace "/" "_" parenth
  93                       symbol = sym1 ++ "__" ++ smethod ++ "__" ++ sym2
  94                   printfMp "native-call: symbol: %s\n" symbol
  95                   nf <- loadNativeFunction symbol
  96                   setMethodMap $ M.insert mi' nf mmap
  97                   return nf
  98               else do
  99                 rawmethod <- parseMethod cls' method sig
 100                 entry <- compileBB rawmethod (MethodInfo method (thisClass cls') sig)
 101                 addMethodRef entry mi' clsnames
 102                 return $ fromIntegral entry
 103         Nothing -> error $ show method ++ " not found. abort"
 104     Just w32 -> return w32
 105   return $ fromIntegral entryaddr
 106
 107 funPtrToAddr :: Num b => FunPtr a -> b
 108 funPtrToAddr = fromIntegral . ptrToIntPtr . castFunPtrToPtr
 109
 110 lookupMethodRecursive :: B.ByteString -> MethodSignature -> [B.ByteString] -> Class Direct
 111                          -> IO (Maybe (Method Direct, [B.ByteString], Class Direct))
 112 lookupMethodRecursive name sig clsnames cls =
 113   case res of
 114     Just x -> return $ Just (x, nextclsn, cls)
 115     Nothing -> if thisname == "java/lang/Object"
 116       then return Nothing
 117       else do
 118         supercl <- getClassFile (superClass cls)
 119         lookupMethodRecursive name sig nextclsn supercl
 120   where
 121     res = lookupMethodSig name sig cls
 122     thisname = thisClass cls
 123     nextclsn :: [B.ByteString]
 124     nextclsn = thisname:clsnames
 125
 126 -- TODO(bernhard): UBERHAX.  ghc patch?
 127 foreign import ccall safe "lookupSymbol"
 128    c_lookupSymbol :: CString -> IO (Ptr a)
 129
 130 loadNativeFunction :: String -> IO NativeWord
 131 loadNativeFunction sym = do
 132   _ <- loadRawObject "ffi/native.o"
 133   -- TODO(bernhard): WTF
 134   resolveObjs (return ())
 135   ptr <- withCString sym c_lookupSymbol
 136   if ptr == nullPtr
 137     then error $ "dyn. loading of \"" ++ sym ++ "\" failed."
 138     else return $ fromIntegral $ ptrToIntPtr ptr
 139
 140 -- t_01 :: IO ()
 141 -- t_01 = do
 142 --   (entry, _) <- testCase "./tests/Fib.class" "fib"
 143 --   let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: NativeWord)
 144 --   let mmap = M.insert ("fib" :: String) int_entry M.empty
 145 --   mapM_ (\(x,y) -> printf "%s at 0x%08x\n" x y) $ M.toList mmap
 146 --   mmap2ptr mmap >>= set_mmap
 147 --   demo_mmap -- access Data.Map from C
 148
 149 addMethodRef :: NativeWord -> MethodInfo -> [B.ByteString] -> IO ()
 150 addMethodRef entry (MethodInfo mmname _ msig) clsnames = do
 151   mmap <- getMethodMap
 152   let newmap = foldr (\i -> M.insert (MethodInfo mmname i msig) entry) M.empty clsnames
 153   setMethodMap $ mmap `M.union` newmap
 154
 155
 156 compileBB :: RawMethod -> MethodInfo -> IO NativeWord
 157 compileBB rawmethod methodinfo = do
 158   tmap <- getTrapMap
 159
 160   cls <- getClassFile (methClassName methodinfo)
 161   let ebb = emitFromBB cls rawmethod
 162   let cgconfig = defaultCodeGenConfig { codeBufferSize = fromIntegral $ (rawCodeLength rawmethod) * 32 }
 163   (_, Right right) <- runCodeGenWithConfig ebb () () cgconfig
 164
 165   let ((entry, _, _, new_tmap), _) = right
 166   setTrapMap $ tmap `M.union` new_tmap -- prefers elements in tmap
 167
 168   printfJit "generated code of \"%s\" from \"%s\":\n" (toString $ methName methodinfo) (toString $ methClassName methodinfo)
 169   printfJit "\tstacksize: 0x%04x, locals: 0x%04x\n" (rawStackSize rawmethod) (rawLocals rawmethod)
 170 #ifdef DBG_JIT
 171   mapM_ (printfJit "%s\n" . showAtt) (snd right)
 172 #endif
 173   printfJit "\n\n"
 174   -- UNCOMMENT NEXT LINES FOR GDB FUN
 175   -- if (toString $ methName methodinfo) == "thejavamethodIwant2debug"
 176   --   then putStrLn "press CTRL+C now for setting a breakpoint. then `c' and ENTER for continue" >> getLine
 177   --   else return "foo"
 178   -- (1) build a debug build (see HACKING) and execute `make tests/Fib.gdb'
 179   --     for example, where the suffix is important
 180   -- (2) on getLine, press CTRL+C
 181   -- (3) `br *0x<addr>'; obtain the address from the disasm above
 182   -- (4) `cont' and press enter
 183   return $ fromIntegral $ ptrToIntPtr entry
 184
 185
 186 executeFuncPtr :: NativeWord -> IO ()
 187 executeFuncPtr entry =
 188   code_void ((castPtrToFunPtr $ intPtrToPtr $ fromIntegral entry) :: FunPtr (IO ()))