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