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