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