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, JpcNpcMap)
  43 getMethodEntry mi@(MethodInfo method cm sig) = do
  44   mmap <- getMethodMap
  45
  46   (entryaddr, jnmap) <- 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, M.empty)
  61                     "printGCStats" ->
  62                        return (funPtrToAddr printGCStatsAddr, M.empty)
  63                     "printMemoryUsage" ->
  64                        return (funPtrToAddr printMemoryUsageAddr, M.empty)
  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                   let nf' = (nf, M.empty)
  76                   setMethodMap $ M.insert mi nf' mmap
  77                   return nf'
  78               else do
  79                 rawmethod <- parseMethod cls' method sig
  80                 entry <- compileBB mi rawmethod (MethodInfo method (thisClass cls') sig)
  81                 addMethodRef entry mi clsnames
  82                 return entry
  83         Nothing -> error $ show method ++ " not found. abort"
  84     Just w32 -> return w32
  85   return (fromIntegral entryaddr, jnmap)
  86
  87 funPtrToAddr :: Num b => FunPtr a -> b
  88 funPtrToAddr = fromIntegral . ptrToIntPtr . castFunPtrToPtr
  89
  90 lookupMethodRecursive :: B.ByteString -> MethodSignature -> [B.ByteString] -> Class Direct
  91                          -> IO (Maybe (Method Direct, [B.ByteString], Class Direct))
  92 lookupMethodRecursive name sig clsnames cls =
  93   case res of
  94     Just x -> return $ Just (x, nextclsn, cls)
  95     Nothing -> if thisname == "java/lang/Object"
  96       then return Nothing
  97       else do
  98         supercl <- getClassFile (superClass cls)
  99         lookupMethodRecursive name sig nextclsn supercl
 100   where
 101     res = lookupMethodSig name sig cls
 102     thisname = thisClass cls
 103     nextclsn :: [B.ByteString]
 104     nextclsn = thisname:clsnames
 105
 106 -- TODO(bernhard): UBERHAX.  ghc patch?
 107 foreign import ccall safe "lookupSymbol"
 108    c_lookupSymbol :: CString -> IO (Ptr a)
 109
 110 loadNativeFunction :: String -> IO NativeWord
 111 loadNativeFunction sym = do
 112   _ <- loadRawObject "ffi/native.o"
 113   -- TODO(bernhard): WTF
 114   resolveObjs (return ())
 115   ptr <- withCString sym c_lookupSymbol
 116   if ptr == nullPtr
 117     then error $ "dyn. loading of \"" ++ sym ++ "\" failed."
 118     else return $ fromIntegral $ ptrToIntPtr ptr
 119
 120 -- t_01 :: IO ()
 121 -- t_01 = do
 122 --   (entry, _) <- testCase "./tests/Fib.class" "fib"
 123 --   let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: NativeWord)
 124 --   let mmap = M.insert ("fib" :: String) int_entry M.empty
 125 --   mapM_ (\(x,y) -> printf "%s at 0x%08x\n" x y) $ M.toList mmap
 126 --   mmap2ptr mmap >>= set_mmap
 127 --   demo_mmap -- access Data.Map from C
 128
 129 addMethodRef :: (NativeWord, JpcNpcMap) -> MethodInfo -> [B.ByteString] -> IO ()
 130 addMethodRef entry (MethodInfo mmname _ msig) clsnames = do
 131   mmap <- getMethodMap
 132   let newmap = foldr (\i -> M.insert (MethodInfo mmname i msig) entry) M.empty clsnames
 133   setMethodMap $ mmap `M.union` newmap
 134
 135
 136 compileBB :: MethodInfo -> RawMethod -> MethodInfo -> IO (NativeWord, JpcNpcMap)
 137 compileBB mi rawmethod methodinfo = do
 138   tmap <- getTrapMap
 139
 140   cls <- getClassFile (methClassName methodinfo)
 141   printfJit $ printf "emit code of \"%s\" from \"%s\":\n" (toString $ methName methodinfo) (toString $ methClassName methodinfo)
 142   let ebb = emitFromBB cls mi rawmethod
 143   let cgconfig = defaultCodeGenConfig { codeBufferSize = fromIntegral $ rawCodeLength rawmethod * 32 }
 144   (jnmap, Right right) <- runCodeGenWithConfig ebb () M.empty cgconfig
 145
 146   let ((entry, _, new_tmap), _) = right
 147   setTrapMap $ tmap `M.union` new_tmap -- prefers elements in tmap
 148
 149   printfJit $ printf "generated code of \"%s\" from \"%s\":\n" (toString $ methName methodinfo) (toString $ methClassName methodinfo)
 150   printfJit $ printf "\tstacksize: 0x%04x, locals: 0x%04x\n" (rawStackSize rawmethod) (rawLocals rawmethod)
 151   when mateDEBUG $ mapM_ (printfJit . printf "%s\n" . showIntel) (snd right)
 152   printfJit $ printf "\n\n"
 153   -- UNCOMMENT NEXT LINES FOR GDB FUN
 154   -- if (toString $ methName methodinfo) == "thejavamethodIwant2debug"
 155   --   then putStrLn "press CTRL+C now for setting a breakpoint. then `c' and ENTER for continue" >> getLine
 156   --   else return "foo"
 157   -- (1) build a debug build (see HACKING) and execute `make tests/Fib.gdb'
 158   --     for example, where the suffix is important
 159   -- (2) on getLine, press CTRL+C
 160   -- (3) `br *0x<addr>'; obtain the address from the disasm above
 161   -- (4) `cont' and press enter
 162   return (fromIntegral $ ptrToIntPtr entry, jnmap)
 163
 164
 165 executeFuncPtr :: NativeWord -> IO ()
 166 executeFuncPtr entry =
 167   code_void ((castPtrToFunPtr $ intPtrToPtr $ fromIntegral entry) :: FunPtr (IO ()))