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