Mate/MethodPool.hs

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