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 :: MethodInfo -> IO CPtrdiff
  42 getMethodEntry mi@(MethodInfo method cm sig) = do
  43   mmap <- getMethodMap
  44
  45   entryaddr <- case M.lookup mi mmap of
  46     Nothing -> do
  47       cls <- getClassFile cm
  48       printfMp $ printf "getMethodEntry: no method \"%s\" found. compile it\n" (show mi)
  49       mm <- lookupMethodRecursive method sig [] cls
  50       case mm of
  51         Just (mm', clsnames, cls') -> do
  52             let flags = methodAccessFlags mm'
  53             if S.member ACC_NATIVE flags
  54               then do
  55                 let scm = toString cm; smethod = toString method
  56                 if scm == "jmate/lang/MateRuntime" then do
  57                   case smethod of
  58                     "loadLibrary" ->
  59                        return . funPtrToAddr $ loadLibraryAddr
  60                     "printGCStats" ->
  61                        return . funPtrToAddr $ printGCStatsAddr
  62                     "printMemoryUsage" ->
  63                        return . funPtrToAddr $ printMemoryUsageAddr
  64                     _ ->
  65                        error $ "native-call: " ++ smethod ++ " not found."
  66                 else do
  67                   -- TODO(bernhard): cleaner please... *do'h*
  68                   let sym1 = replace "/" "_" scm
  69                       parenth = replace "(" "_" $ replace ")" "_" $ toString $ encode sig
  70                       sym2 = replace ";" "_" $ replace "/" "_" parenth
  71                       symbol = sym1 ++ "__" ++ smethod ++ "__" ++ sym2
  72                   printfMp $ printf "native-call: symbol: %s\n" symbol
  73                   nf <- loadNativeFunction symbol
  74                   setMethodMap $ M.insert mi nf mmap
  75                   return nf
  76               else do
  77                 rawmethod <- parseMethod cls' method sig
  78                 entry <- compileBB rawmethod (MethodInfo method (thisClass cls') sig)
  79                 addMethodRef entry mi clsnames
  80                 return $ fromIntegral entry
  81         Nothing -> error $ show method ++ " not found. abort"
  82     Just w32 -> return w32
  83   return $ fromIntegral entryaddr
  84
  85 funPtrToAddr :: Num b => FunPtr a -> b
  86 funPtrToAddr = fromIntegral . ptrToIntPtr . castFunPtrToPtr
  87
  88 lookupMethodRecursive :: B.ByteString -> MethodSignature -> [B.ByteString] -> Class Direct
  89                          -> IO (Maybe (Method Direct, [B.ByteString], Class Direct))
  90 lookupMethodRecursive name sig clsnames cls =
  91   case res of
  92     Just x -> return $ Just (x, nextclsn, cls)
  93     Nothing -> if thisname == "java/lang/Object"
  94       then return Nothing
  95       else do
  96         supercl <- getClassFile (superClass cls)
  97         lookupMethodRecursive name sig nextclsn supercl
  98   where
  99     res = lookupMethodSig name sig cls
 100     thisname = thisClass cls
 101     nextclsn :: [B.ByteString]
 102     nextclsn = thisname:clsnames
 103
 104 -- TODO(bernhard): UBERHAX.  ghc patch?
 105 foreign import ccall safe "lookupSymbol"
 106    c_lookupSymbol :: CString -> IO (Ptr a)
 107
 108 loadNativeFunction :: String -> IO NativeWord
 109 loadNativeFunction sym = do
 110   _ <- loadRawObject "ffi/native.o"
 111   -- TODO(bernhard): WTF
 112   resolveObjs (return ())
 113   ptr <- withCString sym c_lookupSymbol
 114   if ptr == nullPtr
 115     then error $ "dyn. loading of \"" ++ sym ++ "\" failed."
 116     else return $ fromIntegral $ ptrToIntPtr ptr
 117
 118 -- t_01 :: IO ()
 119 -- t_01 = do
 120 --   (entry, _) <- testCase "./tests/Fib.class" "fib"
 121 --   let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: NativeWord)
 122 --   let mmap = M.insert ("fib" :: String) int_entry M.empty
 123 --   mapM_ (\(x,y) -> printf "%s at 0x%08x\n" x y) $ M.toList mmap
 124 --   mmap2ptr mmap >>= set_mmap
 125 --   demo_mmap -- access Data.Map from C
 126
 127 addMethodRef :: NativeWord -> MethodInfo -> [B.ByteString] -> IO ()
 128 addMethodRef entry (MethodInfo mmname _ msig) clsnames = do
 129   mmap <- getMethodMap
 130   let newmap = foldr (\i -> M.insert (MethodInfo mmname i msig) entry) M.empty clsnames
 131   setMethodMap $ mmap `M.union` newmap
 132
 133
 134 compileBB :: RawMethod -> MethodInfo -> IO NativeWord
 135 compileBB rawmethod methodinfo = do
 136   tmap <- getTrapMap
 137
 138   cls <- getClassFile (methClassName methodinfo)
 139   let ebb = emitFromBB cls rawmethod
 140   let cgconfig = defaultCodeGenConfig { codeBufferSize = fromIntegral $ (rawCodeLength rawmethod) * 32 }
 141   (_, Right right) <- runCodeGenWithConfig ebb () () cgconfig
 142
 143   let ((entry, _, _, new_tmap), _) = right
 144   setTrapMap $ tmap `M.union` new_tmap -- prefers elements in tmap
 145
 146   printfJit $ printf "generated code of \"%s\" from \"%s\":\n" (toString $ methName methodinfo) (toString $ methClassName methodinfo)
 147   printfJit $ printf "\tstacksize: 0x%04x, locals: 0x%04x\n" (rawStackSize rawmethod) (rawLocals rawmethod)
 148   if mateDEBUG
 149     then mapM_ (printfJit . printf "%s\n" . showAtt) (snd right)
 150     else return ()
 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 ()))